[LISP函数]：谁有“自动切换图层”的源码？

userzhluserzhl

如题，谁有“自动切换图层”的源码？
[CODE]

                               
登录/注册后可看大图

Underway

Ref:

http://discussion.autodesk.com/thread.jspa?threadID=370371

userzhluserzhl

看了，全都是E文，看不懂，试了也不行，楼上高手Underway可否再说得详细点，或者帮我看看：
(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 "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" 9 "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 "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))

((= 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 )
加载了后没有用呀。

Underway

每一家公司的需求未尽相同,得依自己的工作环境来客制化
这个很难找到可直接套用的程序,费时费力的工程啊

userzhluserzhl

楼上，可不可以说说怎么用？

Underway

先得学会善用 Reactor
这儿有个参考学习的地方
http://www.acadx.com/

NET-JOB

*** ------ Layer Reactor Activated. ------ ***; 错误: no function definition:
VLR_COMMANDXREF-IT

ljpnb

贴一个我简化过的，前提是保存所需要的层都已经存在，只作一个参考
[php]
(vl-load-com)
(if (not COMSTART)
  (setq        COMSTART
         (vlr-editor-reactor
           NIL
           '((:vlr-commandwillstart . COMS)
             ;;(:vlr-commandended . COME)
            )
         )
  )
)

(defun COMS (OBJREACTOR LSTCOMMAND)
  (setq        lst1 '("DIMLINEAR"         "DIMANGULAR"           "DIMARC"
               "DIMDIAMETER"         "DIMORDINATE"           "DIMRADIUS"
               "DIMJOGGED"         "DIMALIGNED"           "DIMCONTINUE"
               "DIMBASELINE"
              )
  )
  (COND        ((member (car LSTCOMMAND) '("HATCH" "BHATCH"))
         (IF (/= (GETVAR "CLAYER") "HATCH")
           (setvar "clayer" "HATCH") ;_打剖面线时自动切换到"HATCH"层
         )
        )
        ((member (car LSTCOMMAND) lst1)
         (IF (/= (GETVAR "CLAYER") "DIM")
           (setvar "clayer" "DIM")   ;_标注尺寸时自动切换到"DIM"层
         )
        )
        ((member (car LSTCOMMAND) '("TEXT" "DTEXT" "MTEXT"))
         (IF (/= (GETVAR "CLAYER") "TEXT")
           (setvar "clayer" "TEXT")   ;_打文字时自动切换到"TEXT"层
         )
        )
        (T
         (IF (/= (GETVAR "CLAYER") "CONTINUOUS")
           (setvar "clayer" "CONTINUOUS");_其它情况下一般在"CONTIUNUOUS"层
         )
        )
  )
  (princ)

)[/php]

userzhluserzhl

楼上，如果输入文字的话，它会自动切换到文字层，我这样改了一下，也不行：
(vl-load-com)
(if (not COMSTART)
  (setq    COMSTART
     (vlr-editor-reactor
       NIL
       '((:vlr-commandwillstart . COMS)
         ;;(:vlr-commandended . COME)
        )
     )
  )
)

(defun COMS (OBJREACTOR LSTCOMMAND)
(setq odlay (getvar "clayer"))
  (setq    lst1 '("DIMLINEAR"     "DIMANGULAR"       "DIMARC"
           "DIMDIAMETER"     "DIMORDINATE"       "DIMRADIUS"
           "DIMJOGGED"     "DIMALIGNED"       "DIMCONTINUE"
           "DIMBASELINE"
          )
  )
  (COND    ((member (car LSTCOMMAND) '("HATCH" "BHATCH"))
     (IF (/= (GETVAR "CLAYER") "HAT")
       (setvar "clayer" "HAT") ;_打剖面线时自动切换到"HATCH"层
     )
    )
    ((member (car LSTCOMMAND) lst1)
     (IF (/= (GETVAR "CLAYER") "DIM")
       (setvar "clayer" "DIM")   ;_标注尺寸时自动切换到"DIM"层
     )
    )
    ((member (car LSTCOMMAND) '("TEXT" "DTEXT" "MTEXT"))
     (IF (/= (GETVAR "CLAYER") "TXT")
       (setvar "clayer" "TXT")   ;_打文字时自动切换到"TXT"层
     )
    )
    (T
     (IF (/= (GETVAR "CLAYER") "CONTINUOUS")
       (setvar "clayer" "CONTINUOUS");_其它情况下一般在"CONTIUNUOUS"层
     )
    )
  )
  (princ)
(command "layer" "s" odlay "")
)

Underway

**** 前提是保存所需要的层都已经存在 ****
!!!!????

userzhluserzhl

不好意思，楼上，你再看看，我改过来了（没想到你回复那么快：）
(setq odlay (getvar "clayer"))
好像没有用，是不是放错地方了？

Underway

;; (command "layer" "s" odlay "")

=====>
(Setvar "Clayer" odlay)

ljpnb

(setq odlay (getvar "clayer"))和(command "layer" "s" odlay "")这两句我感觉没有必要，既然输入命令时层就会自动变换，又何必多出这一步操作呢。

userzhluserzhl

楼上，举个例：
当前层是“7”层，输入文字后（文字为TXT层），自动回到“7”层，中途中断也会回到“7”层，正如顾文伟的那个程序一样。

ljpnb

TO  userzhluserzhl ：你的意思我明白，3楼引用的那个程序可以说比较完善的。我贴的那个只是很简单的一部份，对“命令取消操作”和“图层不存在”等都没有进行操作。我也说明了，前提是保证所要的图层都已经建好了，但是如果中途取消操作，我个人认为对图层是否恢复到初始状态并不影响，因为只要输入命令图层自动会变换，只不过看起来不爽而已。