求大神指导快速切换图层的LSP代码修改

ㄘ丶转裑ㄧ灬 · 发表于 2014-11-17 13:06:19

自动切换图层，你可以参考下，（注：网络收集，感谢原作者！）

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;自动图层切换
(defun xlr-autolayer ()
;;;; (setvar "cmdecho" 0)
;;;; (if (null (tblsearch "layer" "text"))
;;;; (set_layer_list "text" 3 "continuous")
;;;; )
;;;; (if (null (tblsearch "layer" "标注"))
;;;; (set_layer_list "标注" 3 "continuous")
;;;; )
(vl-load-com)
;;;; 图层初始化列表内容：commands layers color linetype plottable
(setq *doc (vla-get-activedocument (vlax-get-acad-object)))
(setq *lays (vla-get-layers *doc))
(setq *laylst
(list (list "DIMANGULAR" "DIM." 8 "continuous" T)
(list "DIMALIGNED" "DIM." 8 "continuous" T)
(list "DIMBASELINE" "DIM." 8 "continuous" T)
(list "DIMCENTER" "DIM." 8 "continuous" T)
(list "DIMCONTINUE" "DIM." 8 "continuous" T)
(list "DIMDIAMETER" "DIM." 8 "continuous" T)
(list "DIMLINEAR" "DIM." 8 "continuous" T)
(list "DIMORDINATE" "DIM." 8 "continuous" T)
(list "DIMRADIUS" "DIM." 8 "continuous" T)
(list "QDIM" "DIM." 8 "continuous" T)
(list "QLEADER" "引线标注" 8 "continuous" T)
(list "DIMARC" "DIM." 8 "continuous" T)
(list "DTEXT" "TEXT" 3 "continuous" T)
(list "MTEXT" "TEXT" 3 "continuous" T)
(list "TEXT" "TEXT" 3 "continuous" T)
(list "BHATCH" "填充" 8 "continuous" T)
(list "HATCH" "填充" 8 "continuous" T)
(list "POINT" "点" 4 "continuous" T)
(list "XLINE" "辅助线" 1 "continuous" T)
(list "REVCLOUD" "修订内容" 6 "continuous" T)
;;;;(list "LINE" "0" NIL "continuous" T)
;;;;(list "XREF" "引用" 7 "continuous" T)
(list "circle" "临时标记" 1 "continuous" T)
(list "RECTANG" "预用" 8 "continuous" T)
;;;;(list "pline" "多义线" 2 "center" T)
)
)
(setq OldLayer nil)
(setq *cmdlst (mapcar 'strcase (mapcar 'car *laylst)))
(mapcar '(lambda (x) (vlr-command-reactor nil x))
(list '((:vlr-commandWillStart . xlr-start))
'((:vlr-commandEnded . xlr-end))
'((:vlr-commandCancelled . xlr-cancel))
)
)
(vlr-editor-reactor
nil
'((:vlr-commandwillstart . xlr-edit))
)
)
;;;;----------------------------------------------------------------------------;;;;
(defun xlr-edit (CALL CALLBACK /)
(foreach N *laylst
(if (= (strcase (car CALLBACK)) (strcase (car N)))
;;;; 命令反应器返回信息如果与设置的命令相同.
(progn ;;;;建立图层
(apply 'xsetlays (cdr N))
;;;;(setvar "CLAYER" (cadr N));设为当前层.
)
)
)
)
;;;;----------------------------------------------------------------------------;;;;
(defun xlr-start (calling-reactor xlr-startInfo /)
(foreach N *laylst
(if (= (strcase (car xlr-startInfo)) (strcase (car N)))
;;;; 命令反应器返回信息如果与设置的命令相同.
(progn ;;;;建立图层
(apply 'xsetlays (cdr N))
;;;;(setvar "CLAYER" (cadr N));设为当前层.
)
)
)
)
;;;;----------------------------------------------------------------------------;;;;
(defun xlr-end (calling-reactor xlr-endInfo / cmd)
(setq cmd (car xlr-endInfo))
(if (member cmd *cmdlst)
(if (/= oldlayer nil)
(progn
(setvar "CLAYER" OldLayer)
(setq OldLayer nil)
)
)
)
)
;;;;----------------------------------------------------------------------------;;;;
(defun xlr-cancel (calling-reactor xlr-cancelInfo / cmd)
(setq cmd (car xlr-cancelInfo))
(if (member cmd *cmdlst)
(if (/= oldlayer nil)
(progn
(setvar "CLAYER" OldLayer)
(setq OldLayer nil)
)
)
)
)
;;;;----------------------------------------------------------------------------;;;;
;;;;----------------------------------------------------------------------------;;;;
(defun xsetlays (LAY-NAM COLOR LTYPE plotk / LAYOBJ LTYPESOBJ)
(if (tblobjname "layer" LAY-NAM)
(progn
(if (/= (strcase (getvar "CLAYER"))
(strcase LAY-NAM)
)
(setq OldLayer (getvar "CLAYER"))
(progn
(if (= oldlayer nil)
(setq OldLayer LAY-NAM)
)
)
)
(setvar "CLAYER" lay-nam)
)
(progn ;;;;添加图层.
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-add (list *lays LAY-NAM))
)
(setq LAYOBJ (vla-item *lays LAY-NAM))
(if (not (tblobjname "ltype" LTYPE)) ;添加线型.
(progn
(setq LTYPESOBJ (vla-get-linetypes *doc))
(vla-load LTYPESOBJ LTYPE (findfile "acad.lin"))
;;;;>>>　要加强，在多个*.lin寻找
(vlax-release-object LTYPESOBJ)
)
);;;;解冻(如冻结)，解锁,设图层为当前,设图层颜色，可打印特性.
(vla-put-layeron layobj :vlax-true)
(vla-put-lock layobj :vlax-false)
(if (= (strcase (getvar "CLAYER")) (strcase lay-nam)) ;解冻.
(vla-put-freeze layobj :vlax-false)
)
(vla-put-color layobj color)
(vla-put-linetype layobj LTYPE)
(vla-put-plottable
layobj
(if plotk
:vlax-true
:vlax-false
)
)
)
)
)
(xlr-autolayer) ;;;;加载启动!

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;自动图层切换 
(defun xlr-autolayer () 
;;;;  (setvar "cmdecho" 0) 
;;;;  (if (null (tblsearch "layer" "text")) 
;;;;    (set_layer_list "text" 3 "continuous") 
;;;;  ) 
;;;;  (if (null (tblsearch "layer" "标注")) 
;;;;    (set_layer_list "标注" 3 "continuous") 
;;;;  ) 
  (vl-load-com) 
;;;; 图层初始化列表 内容：commands layers color linetype plottable 
  (setq *doc (vla-get-activedocument (vlax-get-acad-object))) 
  (setq *lays (vla-get-layers *doc)) 
  (setq  *laylst 
   (list (list "DIMANGULAR" "DIM." 8 "continuous" T) 
         (list "DIMALIGNED" "DIM." 8 "continuous" T) 
         (list "DIMBASELINE" "DIM." 8 "continuous" T) 
         (list "DIMCENTER" "DIM." 8 "continuous" T) 
         (list "DIMCONTINUE" "DIM." 8 "continuous" T) 
         (list "DIMDIAMETER" "DIM." 8 "continuous" T) 
         (list "DIMLINEAR" "DIM." 8 "continuous" T) 
         (list "DIMORDINATE" "DIM." 8 "continuous" T) 
         (list "DIMRADIUS" "DIM." 8 "continuous" T) 
         (list "QDIM" "DIM." 8 "continuous" T) 
         (list "QLEADER" "引线标注" 8 "continuous" T) 
       (list "DIMARC" "DIM." 8 "continuous" T) 
         (list "DTEXT" "TEXT" 3 "continuous" T) 
         (list "MTEXT" "TEXT" 3 "continuous" T) 
         (list "TEXT" "TEXT" 3 "continuous" T) 
         (list "BHATCH" "填充" 8 "continuous" T) 
         (list "HATCH" "填充" 8 "continuous" T) 
         (list "POINT" "点" 4 "continuous" T) 
         (list "XLINE" "辅助线" 1 "continuous" T) 
         (list "REVCLOUD" "修订内容" 6 "continuous" T) 
;;;;(list "LINE" "0" NIL "continuous" T) 
;;;;(list "XREF" "引用" 7 "continuous" T) 
         (list "circle" "临时标记" 1 "continuous" T) 
       (list "RECTANG" "预用" 8 "continuous" T) 
;;;;(list "pline" "多义线" 2 "center" T) 
   ) 
  ) 
  (setq OldLayer nil) 
  (setq *cmdlst (mapcar 'strcase (mapcar 'car *laylst))) 
  (mapcar '(lambda (x) (vlr-command-reactor nil x)) 
    (list  '((:vlr-commandWillStart . xlr-start)) 
    '((:vlr-commandEnded . xlr-end)) 
    '((:vlr-commandCancelled . xlr-cancel)) 
    ) 
  ) 
  (vlr-editor-reactor 
    nil 
    '((:vlr-commandwillstart . xlr-edit)) 
  ) 
) 
;;;;----------------------------------------------------------------------------;;;; 
(defun xlr-edit  (CALL CALLBACK /) 
  (foreach N *laylst 
    (if  (= (strcase (car CALLBACK)) (strcase (car N))) 
;;;; 命令反应器返回信息如果与设置的命令相同. 
      (progn  ;;;;建立图层 
 
  (apply 'xsetlays (cdr N)) 
;;;;(setvar "CLAYER" (cadr N));设为当前层. 
      ) 
    ) 
  ) 
) 
;;;;----------------------------------------------------------------------------;;;; 
(defun xlr-start (calling-reactor xlr-startInfo /) 
  (foreach N *laylst 
    (if  (= (strcase (car xlr-startInfo)) (strcase (car N))) 
;;;; 命令反应器返回信息如果与设置的命令相同. 
      (progn  ;;;;建立图层 
 
  (apply 'xsetlays (cdr N)) 
;;;;(setvar "CLAYER" (cadr N));设为当前层. 
      ) 
    ) 
  ) 
) 
;;;;----------------------------------------------------------------------------;;;; 
(defun xlr-end (calling-reactor xlr-endInfo / cmd) 
  (setq cmd (car xlr-endInfo)) 
  (if (member cmd *cmdlst) 
    (if  (/= oldlayer nil) 
      (progn 
  (setvar "CLAYER" OldLayer) 
  (setq OldLayer nil) 
      ) 
    ) 
  ) 
) 
;;;;----------------------------------------------------------------------------;;;; 
(defun xlr-cancel (calling-reactor xlr-cancelInfo / cmd) 
  (setq cmd (car xlr-cancelInfo)) 
  (if (member cmd *cmdlst) 
    (if  (/= oldlayer nil) 
      (progn 
  (setvar "CLAYER" OldLayer) 
  (setq OldLayer nil) 
      ) 
    ) 
  ) 
) 
;;;;----------------------------------------------------------------------------;;;; 
;;;;----------------------------------------------------------------------------;;;; 
(defun xsetlays  (LAY-NAM COLOR LTYPE plotk / LAYOBJ LTYPESOBJ) 
 
  (if (tblobjname "layer" LAY-NAM) 
    (progn 
      (if (/= (strcase (getvar "CLAYER")) 
        (strcase LAY-NAM) 
    ) 
  (setq OldLayer (getvar "CLAYER")) 
  (progn 
    (if (= oldlayer nil) 
      (setq OldLayer LAY-NAM) 
    ) 
  ) 
      ) 
      (setvar "CLAYER" lay-nam) 
    ) 
    (progn  ;;;;添加图层. 
      (vl-catch-all-error-p 
  (vl-catch-all-apply 'vla-add (list *lays LAY-NAM)) 
      ) 
      (setq LAYOBJ (vla-item *lays LAY-NAM)) 
      (if (not (tblobjname "ltype" LTYPE)) ;添加线型. 
  (progn 
    (setq LTYPESOBJ (vla-get-linetypes *doc)) 
    (vla-load LTYPESOBJ LTYPE (findfile "acad.lin")) 
;;;;>>>　要加强，在多个*.lin寻找 
    (vlax-release-object LTYPESOBJ) 
  ) 
      );;;;解冻(如冻结)，解锁,设图层为当前,设图层颜色，可打印特性. 
      (vla-put-layeron layobj :vlax-true) 
      (vla-put-lock layobj :vlax-false) 
      (if (= (strcase (getvar "CLAYER")) (strcase lay-nam)) ;解冻. 
  (vla-put-freeze layobj :vlax-false) 
      ) 
      (vla-put-color layobj color) 
      (vla-put-linetype layobj LTYPE) 
      (vla-put-plottable 
  layobj 
  (if plotk 
    :vlax-true 
    :vlax-false 
  ) 
      ) 
    ) 
  ) 
) 
(xlr-autolayer)  ;;;;加载启动!

love1030312 · 发表于 2014-11-18 08:38:09

说真的我也没看懂

magicboy555 · 发表于 2014-11-18 09:30:35

ㄘ丶转裑ㄧ灬发表于 2014-11-17 13:06
自动切换图层，你可以参考下，（注：网络收集，感谢原作者！）

这个看不懂啊....

ㄘ丶转裑ㄧ灬 · 发表于 2014-11-18 12:55:08

magicboy555 发表于 2014-11-18 09:30
这个看不懂啊....

只需加载就行。。然后你正常操作绘图命令。。。
代码里面一些线型、颜色的修改，等你熟悉CAD了就知道很简单的。。

magicboy555 · 发表于 2014-11-18 15:02:29

ㄘ丶转裑ㄧ灬发表于 2014-11-18 12:55
只需加载就行。。然后你正常操作绘图命令。。。
代码里面一些线型、颜色的修改，等你熟悉CAD了就知道很简 ...

加载进去好像没用哦

669423907 · 发表于 2014-11-18 20:27:08

http://bbs.mjtd.com/thread-111246-1-1.html

669423907 · 发表于 2014-11-18 21:00:13

11楼转发的程序是很有有用的，G版也有一个更强大的。
红色圈起来的是CAD的命令，画黑色的是图层名，蓝色圈起来的是图层的线型。
程序加载后是看不出有什么反应的，但CAD运行红色圈起来的命令时，就会自动把命令产生的东西转到画黑色的地方的图层，，，，，，
如果要在程序里设置线宽、颜色、打印，那就得有劳大师们高抬贵手了。
我也是不懂的，只是用着用着，看多了，知道一点点

潇湘飞雨 · 发表于 2014-11-20 09:41:03

好资料感谢分享！

AMTONNY · 发表于 2014-11-28 21:55:49

(command "_.-LAYER" "_OFF" "*" "y" "_ON" "DD" "_SET" "DD" "")给你这个，你自已去做吧

AMTONNY · 发表于 2014-11-28 21:56:36

;以下自动建常用图层
;;by amtonny
;;2008.02.20
;;c:
;(vl-load-com)
;(vl-load-all "cad")
;(1)
(defun s::startup () (c:1))
(defun c:1 (/ layer n dd c dx ux uu bz dm us uz um uj assy assy2 ds p dim pt l center style Standard)
(setvar "blipmode" 0)
 (setvar "osmode" 183)
 (setvar "ORTHOMODE" 1)
(setvar "MODEMACRO" (strcat "<潘工智能冲模助手>全局标注比例" (rtos (getvar "DIMLFAC") 2 2)))
 (command "_.-LAYER" "On" "*" "U" "*" "t" "*" "")
(command "layer" "n" "DD" "c" "2" "DD" "lw" "0.25" "DD" "")
(command "layer" "n" "DX" "c" "1" "DX" "lw" "0.25" "DX" "")
(command "layer" "n" "UX" "c" "210" "UX" "lw" "0.25" "UX" "")
(command "layer" "n" "UU" "c" "7" "UU" "lw" "0.25" "UU" "")
(command "layer" "n" "BZ" "c" "3" "BZ" "lw" "0.25" "BZ" "")
(command "layer" "n" "DM" "c" "4" "DM" "lw" "0.25" "DM" "")
(command "layer" "n" "US" "c" "42" "US" "lw" "0.25" "US" "")
(command "layer" "n" "UZ" "c" "5" "UZ" "lw" "0.25" "UZ" "")
(command "layer" "n" "UM" "c" "183" "UM" "lw" "0.25" "UM" "")
(command "layer" "n" "UJ" "c" "111" "UJ" "lw" "0.25" "UJ" "")
(command "layer" "n" "ASSY" "c" "252" "ASSY" "")
(command "layer" "n" "ASSY2" "c" "123" "ASSY2" "")
(command "layer" "n" "DS" "c" "7" "DS" "lw" "0.13" "DS" "")
(command "layer" "n" "P" "c" "7" "P" "lw" "0.13" "P" "")
(command "layer" "n" "DIM" "c" "7" "DIM" "lw" "0.15" "DIM" "")
(command "layer" "n" "c" "c" "7" "c" "lw" "0.13" "C" "")
(command "layer" "n" "PT" "c" "4" "PT" "lw" "0.13" "PT" "")
(command "layer" "l" "DASHED2" "PT" "lw" "0.13" "DASHED2" "")
(command "layer" "n" "CENTER" "c" "1" "CENTER""lw" "0.13" "CENTER" "")
;(command "layer" "n" "Spring" "c" "1" "CENTER""lw" "0.13" "CENTER" "")
;(command "layer" "l" "CENTER" "CENTER" "" )
;(command "layer" "n" "PUB_TITLE" "c" "4" "PUB_TITLE" "lw" "0.13" "PUB_TITLE" "")
(command "style" "Standard" "宋体" "0" "0.8" "0" "n" "n")
(command "style" "ROMANS" "宋体" "0" "0.8" "0" "n" "n")
 (setq date0 (menucmd "M=$(edtime,$(getvar,date), YY.MO.DD)"))
(prompt "\n 快速建立图层程序由软件工程师潘工设计开发,欢迎使用")
(princ date0)
(prin1)
)

账号		自动登录	找回密码
密码			注册

[提问] 求大神指导快速切换图层的LSP代码修改

点评

本帖子中包含更多资源