请帮助为t添加一个选项
我已经使用这个lisp多次复制一个实体，我想添加一个选项，当复制一个实体时，它会自动将其颜色更改为不同的颜色，这样我就可以看到差异（如果原始是红色，那么下一个将有颜色+1为黄色，下一个将为绿色…）非常感谢你的帮助。
（定义c:c（）
（defun DR_ERR（S）；如果发生错误（如CTRL-C）
（如果（/=S“功能取消”）；当此命令处于活动状态时。。。
（如果（=S“退出/退出中止”）
（普林斯）
（princ（strcat“\n错误：”S））
);如果结束
);如果结束
（如果DR_OER；如果存在旧的错误例程
（setq*错误*DR_OER）；然后，重置它
);如果结束
（如果（非BASEPT）；如果使用初始位移
（foreach x SSELIST（redraw x 4））；取消高亮显示最后一个选择集
)
（setvar“cmdecho”1）；错误时重置命令回显
（普林斯）
);结束错误定义
;**** 设置新的错误处理程序****
（如果（非*调试*）
（如果*错误*
（setq DR\u OER*错误**错误*DR\u错误）
（setq*error*DR\U ERR）
);如果结束
);如果结束
;**** 开始主功能****
（if（setq EMARK（entlast））
（while（setq B（entnext EMARK））
（setq EMARK B）
)
)
（setq SS（ssget））
（setvar“cmdecho”0）
（提示“\n基点或位移：”）
（命令“copy”SS“”暂停）
（setq BASEPT（getvar“lastpoint”））
（提示“\n复制点：”）
（命令暂停）
（if（等于BASEPT（setq lastp（getvar“lastpoint”））
（progn（setq REFPT LASTPT）
（setq BASEPT nil）
)
)
（如果是BASEPT
（while（entnext EMARK）；虽然有新的实体
（setq SSOLD SS）
（setq SS（ssadd））；重置SS
（while（entnext EMARK）；虽然有新的实体
（setq EMARK（entnext EMARK））
（ssadd EMARK SS）；将其添加到新SS
)
（if（等于BASEPT（setq lastp（getvar“lastpoint”））
（progn（命令“erase”SS“”）
（命令“copy”SSOLD“REFPT”）
（setvar“lastpoint”（极性BASEPT ANGLPT DISTPT））
)
（progn（setq ANGLPT（angle BASEPT LASTPT））
（setq DISTPT（距离BASEPT LASTPT））
（setq REFPT（极坐标（0.0 0.0 0.0）ANGLPT DISTPT））
（setq BASEPT LASTPT）；增量基点
（提示（strcat“\n复制点：”））
（命令“copy”SS“”BASEPT pause）
)
)
);结束时
（ssget“P”）
（setq REFPT（获取点（strcat“\n显示：”））
（如果（非参考）
（setq REFPT（getvar“lastpoint”））
)
（命令“copy”SS“REFPT”）
);结束时
);如果结束
（setvar“cmdecho”1）
（普林斯）
);结束defun
（普林斯） 如果选择多个对象（用于复制）并且它们都是不同的颜色，会发生什么？ 我很少使用一个以上的实体，因此我忘了提到。如果可以修改为只复制一个，我会很高兴。 对于单选，将（ssget）替换为（car（entsel））。
您可以使用如下子例程设置颜色，并使用chprop、change、entmod、vla put color来设置颜色。
(defun _colorUp (entity / num)
(if (eq (type entity) 'ENAME)
(if (eq 255
(setq num (abs
(cond ((cdr (assoc 62 (entget entity))))
((cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 (entget entity)))))))
)
)
)
)
1
(1+ num)
)
)
) 我用（car（entsel））更改了（ssget），但它选择了最后绘制的实体，而不是让我选择我想要的实体
给我一个提示，我应该把子程序放在哪一行。
（这比我想象的要高得多）
谢谢
使用Alanjt sub的示例
(defun c:cc( / obj pt1 pt2 )
(defun _colorUp (entity / num)
(if (eq (type entity) 'ENAME)
(if (eq 255
(setq
num
(abs
(cond
((cdr (assoc 62 (entget entity))))
((cdr
(assoc
62
(tblsearch
"LAYER"
(cdr (assoc 8 (entget entity)))))))))))
(setq num 1)
(setq num (1+ num))))
(command "_chprop" entity "" "color" num "")
)
(setq
obj (entsel "\nSelect object to copy: ")
pt1 (getpoint "\nPick base point:"))
(while (setq pt2 (getpoint pt1 "\nNext point:"))
(command "copy" obj "" pt1 pt2)
(setq
pt1 pt2
obj (entlast))
(_colorUp obj)
)
)
希望这有帮助 我现在开始工作了
谢谢pBe 只是为了好玩。。。
(defun c:TEst (/ _colorUp obj lst pt color)
(vl-load-com)
(defun _colorUp (obj / color)
(if (eq 255
(if (vl-position (setq color (vla-get-color obj)) '(0 256))
(setq color (cdr (assoc 62 (tblsearch "LAYER" (vla-get-layer obj)))))
color
)
)
1
(1+ color)
)
)
(if (and (setq obj (car (entsel "\nSelect object to copy: ")))
(setq obj (vlax-ename->vla-object obj))
(car (setq lst (list (getpoint "\nSpecify base point: "))))
)
(while (setq pt (if acet-ss-drag-move
(acet-ss-drag-move
(ssadd (vlax-vla-object->ename obj))
(car lst)
"\nSpecify next point: "
T
)
(getpoint (car lst) "\nSpecify next point: ")
)
)
(setq color (_colorUp obj))
(vla-move (setq obj (vla-copy obj))
(vlax-3d-point (trans (car lst) 1 0))
(vlax-3d-point (trans (car (setq lst (cons pt lst))) 1 0))
)
(vla-put-color obj color)
)
)
(princ)
)
页:
[1]