[转贴]：好用的图层自动切换程序(源代码)

ycao

以前一直用顾文伟的图层自动切换程序，可惜的是程序只能在CAD2006等低版本上使用。苦苦等待顾文伟发布能在高版本CAD上使用的图层自动切换程序，可总是失望。没有了图层切换程序，让人觉得很不方便。现在终于从明经找到了一个好用的图层切换程序，使用了一下，也许没有顾的程序功能强大，但确实好用、实用，并且该程序为vlisp的源代码，可以根据自己的图层使用习惯进行修改，很方便。也许那位高手可以根据该源代码编制出功能更强大的图层自动切换程序。[PHP](defun VLR_COMMAND-IT ()
(vl-load-com)
(vlr-command-reactor nil '((:vlr-commandWillStart . startCommand)))
(vlr-command-reactor nil '((:vlr-commandEnded . endCommand)))
(vlr-command-reactor nil '((:vlr-commandCancelled . cancelCommand)))
(vlr-editor-reactor nil '((:vlr-commandwillstart . ARCH:COM1)))
)
(princ "\n*** ------ Layer Reactor Activated. ------ ***")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;
(defun ARCH:COM1 (CALL CALLBACK / COMLAYLST)
;;; List of corrusponding commands layers color linetype plottable
(setq COMLAYLST
(list (list "DIMANGULAR" "A-DIMS" 30 "continuous" :vlax-true)
(list "DIMBASELINE" "A-DIMS" 30 "continuous" :vlax-true)
(list "DIMCENTER" "A-DIMS" 30 "continuous" :vlax-true)
(list "DIMCONTINUE" "A-DIMS" 30 "continuous" :vlax-true)
(list "DIMDIAMETER" "A-DIMS" 30 "continuous" :vlax-true)
(list "DIMLINEAR" "A-DIMS" 30 "continuous" :vlax-true)
(list "DIMORDINATE" "A-DIMS" 30 "continuous" :vlax-true)
(list "DIMRADIUS" "A-DIMS" 30 "continuous" :vlax-true)
(list "QDIM" "A-DIMS" 30 "continuous" :vlax-true)
(list "DIMALIGNED" "A-DIMS" 30 "continuous" :vlax-true)
(list "DIMARC" "A-DIMS" 30 "continuous" :vlax-true)
(list "DIMJOGGED" "A-DIMS" 30 "continuous" :vlax-true)

(list "LEADER" "A-NOTE" 2 "continuous" :vlax-true)
(list "QLEADER" "A-NOTE" 2 "continuous" :vlax-true)

(list "DTEXT" "A-NOTE" 2 "continuous" :vlax-true)
(list "MTEXT" "A-NOTE" 2 "continuous" :vlax-true)
;;(list "TEXT" "A-NOTE" 2 "continuous" :vlax-true)

(list "BHATCH" "A-PATT" 1 "continuous" :vlax-true)
(list "HATCH" "A-PATT" 9 "continuous" :vlax-true)

(list "POINT" "X-PNTS" 4 "continuous" :vlax-true)

(list "XLINE" "X-LINE" 8 "continuous" :vlax-true)
(list "XREF" "0-XREF" 7 "continuous" :vlax-true)
)
)
(foreach
N COMLAYLST
(if (= (strcase (car CALLBACK)) (strcase (car N)))
(progn
(make_layers
(cadr N)
(caddr N)
(cadddr N)
(car (cddddr N))
)
(setq n1 n)
(vla-put-activelayer
(vla-get-activedocument
(vlax-get-acad-object)
)
(vlax-ename->vla-object
(tblobjname "LAYER" (cadr N))
)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;
;;;;
;;; Make layers using activeX
(defun MAKE_LAYERS (LAY_NAM COLOR LTYPE PLOTL / LAYOBJ LAYSOBJ LTYPESOBJ)
(setq CDWGOBJ (vla-get-activedocument
(vlax-get-acad-object)
)
LAYSOBJ (vla-get-layers CDWGOBJ)
)
(if (not (tblobjname "layer" LAY_NAM))
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-add (list LAYSOBJ LAY_NAM))
)
)
(setq LAYOBJ (vla-item LAYSOBJ LAY_NAM))
(if (not (tblobjname "ltype" LTYPE))
(progn
(setq LTYPESOBJ (vla-get-linetypes CDWGOBJ))
(vla-load LTYPESOBJ LTYPE (findfile "acad.lin"))
(vlax-release-object LTYPESOBJ)
)
)
(vla-put-layeron LAYOBJ :vlax-true)
(if (/= (strcase (vla-get-name LAYOBJ)) (strcase (getvar "clayer")))
(vla-put-freeze LAYOBJ :vlax-false)
)
(vla-put-lock LAYOBJ :vlax-false)
(vla-put-color LAYOBJ COLOR)
(vla-put-linetype LAYOBJ LTYPE)
(vla-put-plottable LAYOBJ PLOTL)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;
;;;;
(defun startCommand (calling-reactor
startcommandInfo
/
thecommandstart
)
(setq OldLayer (getvar "CLAYER"))
;;(vlr-editor-reactor nil '((:vlr-commandwillstart . ARCH:COM1)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;
;;;;
(defun endCommand (calling-reactor
endcommandInfo
/
thecommandend
)
(setq thecommandend (nth 0 endcommandInfo))
(cond
((= thecommandend "DIMANGULAR") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMBASELINE") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMCENTER") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMCONTINUE") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMDIAMETER") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMLINEAR") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMORDINATE") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMRADIUS") (setvar "CLAYER" OldLayer))
((= thecommandend "QDIM") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMALIGNED") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMARC") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMJOGGED") (setvar "CLAYER" OldLayer))

((= thecommandend "LEADER") (setvar "CLAYER" OldLayer))
((= thecommandend "QLEADER") (setvar "CLAYER" OldLayer))

((= thecommandend "DTEXT") (setvar "CLAYER" OldLayer))
((= thecommandend "MTEXT") (setvar "CLAYER" OldLayer))
;;((= thecommandend "TEXT") (setvar "CLAYER" OldLayer))

((= thecommandend "BHATCH") (setvar "CLAYER" OldLayer))
((= thecommandend "HATCH") (setvar "CLAYER" OldLayer))

((= thecommandend "POINT") (setvar "CLAYER" OldLayer))

((= thecommandend "XLINE") (setvar "CLAYER" OldLayer))
((= thecommandend "XREF") (setvar "CLAYER" OldLayer))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;
;;;;
(defun cancelCommand (calling-reactor
cancelcommandInfo
/
thecommandcancel
)
(setq thecommandcancel (nth 0 cancelcommandInfo))
(cond
((= thecommandcancel "DIMANGULAR") (setvar "CLAYER" OldLayer))
((= thecommandcancel "DIMBASELINE") (setvar "CLAYER" OldLayer))
((= thecommandcancel "DIMCENTER") (setvar "CLAYER" OldLayer))
((= thecommandcancel "DIMCONTINUE") (setvar "CLAYER" OldLayer))
((= thecommandcancel "DIMDIAMETER") (setvar "CLAYER" OldLayer))
((= thecommandcancel "DIMLINEAR") (setvar "CLAYER" OldLayer))
((= thecommandcancel "DIMORDINATE") (setvar "CLAYER" OldLayer))
((= thecommandcancel "DIMRADIUS") (setvar "CLAYER" OldLayer))
((= thecommandcancel "QDIM") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMALIGNED") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMARC") (setvar "CLAYER" OldLayer))
((= thecommandend "DIMJOGGED") (setvar "CLAYER" OldLayer))


((= thecommandcancel "LEADER") (setvar "CLAYER" OldLayer))
((= thecommandcancel "QLEADER") (setvar "CLAYER" OldLayer))

((= thecommandcancel "DTEXT") (setvar "CLAYER" OldLayer))
((= thecommandcancel "MTEXT") (setvar "CLAYER" OldLayer))
;;((= thecommandcancel "TEXT") (setvar "CLAYER" OldLayer))

((= thecommandcancel "BHATCH") (setvar "CLAYER" OldLayer))
((= thecommandcancel "HATCH") (setvar "CLAYER" OldLayer))

((= thecommandcancel "POINT") (setvar "CLAYER" OldLayer))

((= thecommandcancel "XLINE") (setvar "CLAYER" OldLayer))
((= thecommandcancel "XREF") (setvar "CLAYER" OldLayer))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;
;;;;
(VLR_COMMAND-IT)
(defun ARCH:COMXREF1 (CALL CALLBACK / COMLAYLST)
;;; List of corrusponding commands layers color linetype plottable
(setq COMLAYLST
(list
(list "XREF" "0-XREF" 7 "continuous" :vlax-true)
)
)
(foreach
N COMLAYLST
(if (= (strcase (car CALLBACK)) (strcase (car N)))
(progn
(make_layers
(cadr N)
(caddr N)
(cadddr N)
(car (cddddr N))
)
(setq n1 n)
(vla-put-activelayer
(vla-get-activedocument
(vlax-get-acad-object)
)
(vlax-ename->vla-object
(tblobjname "LAYER" (cadr N))
)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;
;;;;
;;; Make layers using activeX
(defun MAKE_LAYERS (LAY_NAM COLOR LTYPE PLOTL / LAYOBJ LAYSOBJ LTYPESOBJ)
(setq CDWGOBJ (vla-get-activedocument
(vlax-get-acad-object)
)
LAYSOBJ (vla-get-layers CDWGOBJ)
)
(if (not (tblobjname "layer" LAY_NAM))
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-add (list LAYSOBJ LAY_NAM))
)
)
(setq LAYOBJ (vla-item LAYSOBJ LAY_NAM))
(if (not (tblobjname "ltype" LTYPE))
(progn
(setq LTYPESOBJ (vla-get-linetypes CDWGOBJ))
(vla-load LTYPESOBJ LTYPE (findfile "acad.lin"))
(vlax-release-object LTYPESOBJ)
)
)
(vla-put-layeron LAYOBJ :vlax-true)
(if (/= (strcase (vla-get-name LAYOBJ)) (strcase (getvar "clayer")))
(vla-put-freeze LAYOBJ :vlax-false)
)
(vla-put-lock LAYOBJ :vlax-false)
(vla-put-color LAYOBJ COLOR)
(vla-put-linetype LAYOBJ LTYPE)
(vla-put-plottable LAYOBJ PLOTL)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;Kenny Ramage @ afralisp.com
(defun startCommandxref (calling-reactor
startCommandxrefInfo
/
thecommandstart
)
(setq OldLayer (getvar "CLAYER"))
;;(vlr-editor-reactor nil '((:vlr-commandwillstart . ARCH:COMXREF1)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
(defun endCommandxref (calling-reactor
endCommandxrefInfo
/
thecommandendxref
)
(setq thecommandendxref (nth 0 endCommandxrefInfo))
(cond
((= thecommandendxref "XREF") (setvar "CLAYER" OldLayer))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;
;;;;
(defun cancelCommandxref (calling-reactor
cancelCommandxrefInfo
/
thecommandcancelxref
)
(setq thecommandcancelxref (nth 0 cancelCommandxrefInfo))
(cond
((= thecommandcancelxref "XREF") (setvar "CLAYER" OldLayer))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;
;;;;
(VLR_COMMANDXREF-IT)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
(princ )[/PHP]

adisonmaster

好东西，先收下，慢慢研究！

qiaqiadeng

看见vlx我就头大,懒得研究了,楼主说说功能吧,要不就云雾里不知庐山何处.

ycao

把该程序在CAD里加载(可以设置成自动加载)。比如：你标注尺寸时，就自动切换到了你设置的标注尺寸所在的图层，而不需你手动进行换层。程序中这样的语句是建立尺寸标注的图层的：
(list "DIMANGULAR" "A-DIMS" 30 "continuous" :vlax-true)  该语句的作用就是在进行DIMANGULAR尺寸标注时，自动切换到图层"A-DIMS" ，该图层的颜色为第30号颜色。你可以根据自己的标注习惯进行修改。比如：(list "DIMANGULAR" "dim" 1 "continuous" :vlax-true)  。

egos

如果我事先没有设置相应的图层，程序会不会出错？

ycao

最初由 egos 发布
[B]如果我事先没有设置相应的图层，程序会不会出错？ [/B]

不会出错。如果事先没有设置相应的图层，则会自动建立相应的图层。

hb198075

感觉也不是很方便啊。只对标注，文字之类有效，并且假如我的文字或标注不仅仅是在一个图层的，岂不是每次画完还要再转到我想要的图层？那样更麻烦了。而且标完图层还不能复位。

oysh99

tssd里面已经有，标注自动到dim层。但是对于填充好像没有。
值得学习。

flowerson

好程序，可以实现把画好但没进行归类的图，按填充、文字、标注等重新归好层呢？

yinzhun22

好像不能记录命令运行钱的图层啊
这样运行完就变成当前层，不是很方便
希望高手能修改下

yzsj

明经自己的图层自动切换程序也很好用啊！是用VBA的！

yxianfo

同楼主的经历和感受一样，总在关注自动切换图层的程序，今天在这里见到这个，立即试用，觉得还好，谢谢提供。
这样的程序应该是不会出错的，可稳定运行。遗憾的是程序还不太全面，还有很多命令需要自选图层的功能。有能力的请不断完善，相信有此期待的人还很多，大家一起努力吧。

baolanjun

谢谢ycao提供这么好的源码,以前很少用vl的函数,

bikeboy

看看这个写的怎么样 啊

zongkun

新手，刚准备学学cad二次开发的东西，还不会用这个。