[求助] 求帮忙改程序！！
<p>朋友给了一个LISP小程序，可以根据命令自动将实体标注等归到指定层，但是程序只对CAD自有命令有用，对其他加载的程序命令不起作用，</p><p>哪位高手能帮忙改下，使它能识别自编程序命令，比如通过一个自编程序自动画个钢型才的剖面，输入命令后CAD 就自动跳掉指定的图层，如没有此图层则自动建立，画完以后再跳回命令前的图层，原程序如下：</p>
<p><font face="Verdana"></font> </p>
<p><font face="Verdana">(defun xlr-autolayer ()<br/>; (setvar "cmdecho" 0)<br/>; (if (null (tblsearch "layer" "text"))<br/>; (set_layer_list "text" 3 "continuous")<br/>; )<br/>; (if (null (tblsearch "layer" "dim"))<br/>; (set_layer_list "dim" 3 "continuous")<br/>; )</font></p>
<p><font face="Verdana"> (vl-load-com)<br/> ;; 图层初始化列表 内容：commands layers color linetype plottable<br/> (setq *doc (vla-get-activedocument (vlax-get-acad-object)))<br/> (setq *lays (vla-get-layers *doc))<br/> (setq *laylst <br/> (list (list "DIMANGULAR" "DIM-MQ" 3 "continuous" T)<br/> (list "DIMALIGNED" "DIM-MQ" 3 "continuous" T)<br/> (list "DIMBASELINE" "DIM-MQ" 3 "continuous" T)<br/> (list "DIMCENTER" "DIM-MQ" 3 "continuous" T)<br/> (list "DIMCONTINUE" "DIM-MQ" 3 "continuous" T)<br/> (list "DIMDIAMETER" "DIM-MQ" 3 "continuous" T)<br/> (list "DIMLINEAR" "DIM-MQ" 3 "continuous" T)<br/> (list "DIMORDINATE" "DIM-MQ" 3 "continuous" T)<br/> (list "DIMRADIUS" "DIM-MQ" 3 "continuous" T)<br/> (list "QDIM" "DIM-MQ" 3 "continuous" T)<br/> (list "QLEADER" "DIM-MQ" 3 "continuous" T)<br/> (list "BHATCH" "1-填充" 9 "continuous" T)<br/> (list "HATCH" "1-填充" 9 "continuous" T)<br/> (list "XLINE" "defpoints" 8 "continuous" T)<br/> (list "mleader" "text" 3 "continuous" T)<br/> <br/> )<br/> )<br/> (setq OldLayer nil)<br/> (setq *cmdlst (mapcar 'strcase (mapcar 'car *laylst)))<br/> (mapcar '(lambda (x) (vlr-command-reactor nil x))<br/> (list '((:vlr-commandWillStart . xlr-start))<br/> '((:vlr-commandEnded . xlr-end))<br/> '((:vlr-commandCancelled . xlr-cancel))<br/> )<br/> )<br/> (vlr-editor-reactor<br/> nil<br/> '((:vlr-commandwillstart . xlr-edit))<br/> )<br/>)<br/>;;;----------------------------------------------------------------------------;;;<br/>(defun xlr-edit (CALL CALLBACK /)<br/> (foreach N *laylst<br/> (if (= (strcase (car CALLBACK)) (strcase (car N)))<br/> ; 命令反应器返回信息如果与设置的命令相同.<br/> (progn ;建立图层<br/>(apply 'xsetlays (cdr N))<br/> ;(setvar "CLAYER" (cadr N));设为当前层.<br/> )<br/> )<br/> )<br/>)<br/>;;;----------------------------------------------------------------------------;;;<br/>(defun xlr-start (calling-reactor xlr-startInfo /)<br/> (foreach N *laylst<br/> (if (= (strcase (car xlr-startInfo)) (strcase (car N)))<br/> ; 命令反应器返回信息如果与设置的命令相同.<br/> (progn ;建立图层<br/>(apply 'xsetlays (cdr N))<br/> ;(setvar "CLAYER" (cadr N));设为当前层.<br/> )<br/> )<br/> )<br/>)<br/>;;;----------------------------------------------------------------------------;;;<br/>(defun xlr-end (calling-reactor xlr-endInfo / cmd)<br/> (setq cmd (car xlr-endInfo))<br/> (if (member cmd *cmdlst)<br/> (if (/= oldlayer nil)<br/> (progn <br/> (setvar "CLAYER" OldLayer)<br/> (setq OldLayer nil)<br/> )<br/> )<br/> )<br/>)<br/>;;;----------------------------------------------------------------------------;;;<br/>(defun xlr-cancel (calling-reactor xlr-cancelInfo / cmd)<br/> (setq cmd (car xlr-cancelInfo))<br/> (if (member cmd *cmdlst)<br/> (if (/= oldlayer nil)<br/> (progn <br/> (setvar "CLAYER" OldLayer)<br/> (setq OldLayer nil)<br/> )<br/> )<br/> )<br/>)<br/>;;;----------------------------------------------------------------------------;;;<br/>;;;----------------------------------------------------------------------------;;; <br/>(defun xsetlays (LAY-NAM COLOR LTYPE plotk / LAYOBJ LTYPESOBJ)<br/> (if (tblobjname "layer" LAY-NAM)<br/> (progn<br/> (if (/= (strcase (getvar "CLAYER"))<br/> (strcase LAY-NAM)<br/> )<br/>(setq OldLayer (getvar "CLAYER"))<br/>(progn<br/> (if (= oldlayer nil)<br/> (setq OldLayer LAY-NAM)<br/> )<br/>)<br/> )<br/> (setvar "CLAYER" lay-nam)<br/> )<br/> (progn ;添加图层.<br/> (vl-catch-all-error-p<br/>(vl-catch-all-apply 'vla-add (list *lays LAY-NAM))<br/> )<br/> (setq LAYOBJ (vla-item *lays LAY-NAM))<br/> (if (not (tblobjname "ltype" LTYPE)) ;添加线型.<br/>(progn<br/> (setq LTYPESOBJ (vla-get-linetypes *doc))<br/> (vla-load LTYPESOBJ LTYPE (findfile "acad.lin"))<br/> ;>>> 要加强，在多个*.lin寻找<br/> (vlax-release-object LTYPESOBJ)<br/>)<br/> ) ;解冻(如冻结)，解锁,设图层为当前,设图层颜色，可打印特性.<br/> (vla-put-layeron layobj :vlax-true)<br/> (vla-put-lock layobj :vlax-false)<br/> (if (= (strcase (getvar "CLAYER")) (strcase lay-nam)) ;解冻.<br/>(vla-put-freeze layobj :vlax-false)<br/> )<br/> (vla-put-color layobj color)<br/> (vla-put-linetype layobj LTYPE)<br/> (vla-put-plottable<br/>layobj<br/>(if plotk<br/> :vlax-true<br/> :vlax-false<br/>)<br/> )<br/> )<br/> )<br/>)<br/>(xlr-autolayer) ;加载启动!<br/>(princ "\n ----命令图层反应器已加载----")<br/> <br/></font></p> <p>这个没法改，提供的资料太少。下面是程序中命令与图层对应的数据表，可参照修改。</p>
<p><font face="Verdana">(setq *laylst <br/> '(("DIMANGULAR" "DIM-MQ" 3 "continuous" T)<br/> ("DIMALIGNED" "DIM-MQ" 3 "continuous" T)<br/> ("DIMBASELINE" "DIM-MQ" 3 "continuous" T)<br/> ("DIMCENTER" "DIM-MQ" 3 "continuous" T)<br/> ("DIMCONTINUE" "DIM-MQ" 3 "continuous" T)<br/> ("DIMDIAMETER" "DIM-MQ" 3 "continuous" T)<br/> ("DIMLINEAR" "DIM-MQ" 3 "continuous" T)<br/> ("DIMORDINATE" "DIM-MQ" 3 "continuous" T)<br/> ("DIMRADIUS" "DIM-MQ" 3 "continuous" T)<br/> ("QDIM" "DIM-MQ" 3 "continuous" T)<br/> ("QLEADER" "DIM-MQ" 3 "continuous" T)<br/> ("BHATCH" "1-填充" 9 "continuous" T)<br/> ("HATCH" "1-填充" 9 "continuous" T)<br/> ("XLINE" "defpoints" 8 "continuous" T)<br/> ("mleader" "text" 3 "continuous" T)<br/> )<br/> )<br/></font>第一列参数为命令名</p>
<p>第二列参数为图层名</p>
<p>第三列是颜色</p>
<p>第四列是线型</p> 这个我知道，上面的是我自己该的，这些都是 CAD 自带命令，对于自编命令就没用。 试下用<font face="Verdana">vlax-add-cmd</font>将你的命令添加到ACAD内置命令集中 本帖最后由 作者 于 2010-9-9 20:49:41 编辑 <br /><br /> <p>楼上的命令 没什么反应么？</p>
页:
[1]