自动图层插件有点问题，大家帮忙解决一下，源码也在，
本帖最后由 yoyrtweq 于 2023-8-12 18:10 编辑能够使用，但编译成VLX老是弹出有多余的闭括号，编译终止，找到一些问题，但还是没能解决，大家能否看看是那问题呢！
;;命令自动图层
(defun xlr-autolayer ()
(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 "QLEADER" "图标" 12 "CONTINUOUS" T)
(list "DTEXT" "图标" 12 "CONTINUOUS" T)
(list "MTEXT" "图标" 12 "CONTINUOUS" T)
(list "TEXT" "图标" 12 "CONTINUOUS" T)
(list "CIRCLE" "2 家具-内轮廓线" 7 "CONTINUOUS" T)
(list "ARC" "1 家具-外轮廓线" 7 "CONTINUOUS"T)
(list "PLINE" "1 家具-外轮廓线" 7 "CONTINUOUS" T)
(list "XLINE" "Defpoints" 5 "CONTINUOUS" T)
(list "SPLINE" "1 家具-外轮廓线" 7 "CONTINUOUS" T)
(list "RECTANG" "1 家具-外轮廓线" 7 "CONTINUOUS" T)
(list "CIRCLE" "1 家具-外轮廓线" 7 "CONTINUOUS" T)
(list "LINE" "2 家具-内轮廓线" 7 "CONTINUOUS" T)
(list "MVIEW" "Defpoints" 5 "CONTINUOUS" T)
(list "HATCH" "3 家具-填充线" 34 "CONTINUOUS" T)
(list "BHATCH" "3 家具-填充线" 34 "CONTINUOUS" 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) ;加载启动!
(princ "")
)
程序不全，需要完整程序 放到编辑器里就提示 多余的右括号 很明显的最后一个多余了 飞雪神光 发表于 2023-8-12 20:07
放到编辑器里就提示 多余的右括号 很明显的最后一个多余了
;P恩 是的 删了最后一个可以了！！！！
页:
[1]