[求助] 求帮忙改程序！！

cjjh8301

朋友给了一个LISP小程序，可以根据命令自动将实体标注等归到指定层，但是程序只对CAD自有命令有用，对其他加载的程序命令不起作用，

哪位高手能帮忙改下，使它能识别自编程序命令，比如通过一个自编程序自动画个钢型才的剖面，输入命令后CAD 就自动跳掉指定的图层，如没有此图层则自动建立，画完以后再跳回命令前的图层，原程序如下：

 

(defun xlr-autolayer ()
;  (setvar "cmdecho" 0)
;  (if (null (tblsearch "layer" "text"))
;    (set_layer_list "text" 3 "continuous")
;  )
;  (if (null (tblsearch "layer" "dim"))
;    (set_layer_list "dim" 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-MQ" 3 "continuous" T)
        (list "DIMALIGNED" "DIM-MQ" 3 "continuous" T)
        (list "DIMBASELINE" "DIM-MQ" 3 "continuous" T)
        (list "DIMCENTER" "DIM-MQ" 3 "continuous" T)
        (list "DIMCONTINUE" "DIM-MQ" 3 "continuous" T)
        (list "DIMDIAMETER" "DIM-MQ" 3 "continuous" T)
        (list "DIMLINEAR" "DIM-MQ" 3 "continuous" T)
        (list "DIMORDINATE" "DIM-MQ" 3 "continuous" T)
        (list "DIMRADIUS" "DIM-MQ" 3 "continuous" T)
        (list "QDIM" "DIM-MQ" 3 "continuous" T)
        (list "QLEADER" "DIM-MQ" 3 "continuous" T)
        (list "BHATCH" "1-填充" 9 "continuous" T)
        (list "HATCH" "1-填充" 9 "continuous" T)
        (list "XLINE" "defpoints" 8 "continuous" T)
        (list "mleader" "text" 3 "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 "\n ----命令图层反应器已加载----")
 

ZZXXQQ

这个没法改，提供的资料太少。下面是程序中命令与图层对应的数据表，可参照修改。

(setq *laylst
 '(("DIMANGULAR" "DIM-MQ" 3 "continuous" T)
   ("DIMALIGNED" "DIM-MQ" 3 "continuous" T)
   ("DIMBASELINE" "DIM-MQ" 3 "continuous" T)
   ("DIMCENTER" "DIM-MQ" 3 "continuous" T)
   ("DIMCONTINUE" "DIM-MQ" 3 "continuous" T)
   ("DIMDIAMETER" "DIM-MQ" 3 "continuous" T)
   ("DIMLINEAR" "DIM-MQ" 3 "continuous" T)
   ("DIMORDINATE" "DIM-MQ" 3 "continuous" T)
   ("DIMRADIUS" "DIM-MQ" 3 "continuous" T)
   ("QDIM" "DIM-MQ" 3 "continuous" T)
   ("QLEADER" "DIM-MQ" 3 "continuous" T)
   ("BHATCH" "1-填充" 9 "continuous" T)
   ("HATCH" "1-填充" 9 "continuous" T)
   ("XLINE" "defpoints" 8 "continuous" T)
   ("mleader" "text" 3 "continuous" T)
  )
 )
第一列参数为命令名

第二列参数为图层名

第三列是颜色

第四列是线型

cjjh8301

这个我知道，上面的是我自己该的，这些都是 CAD 自带命令，对于自编命令就没用。

ZZXXQQ

试下用vlax-add-cmd将你的命令添加到ACAD内置命令集中

cjjh8301

楼上的命令 没什么反应么？