请帮助为t添加一个选项

Tunnelrat · 发表于 2022-7-6 09:47:58

我已经使用这个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
（普林斯）

alanjt · 发表于 2022-7-6 09:59:06

如果选择多个对象（用于复制）并且它们都是不同的颜色，会发生什么？

Tunnelrat · 发表于 2022-7-6 10:08:37

我很少使用一个以上的实体，因此我忘了提到。如果可以修改为只复制一个，我会很高兴。

alanjt · 发表于 2022-7-6 10:17:13

对于单选，将（ssget）替换为（car（entsel））。
您可以使用如下子例程设置颜色，并使用chprop、change、entmod、vla put color来设置颜色。

copy

(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)
   )
 )
)

Tunnelrat · 发表于 2022-7-6 10:28:24

我用（car（entsel））更改了（ssget），但它选择了最后绘制的实体，而不是让我选择我想要的实体
给我一个提示，我应该把子程序放在哪一行。
（这比我想象的要高得多）
谢谢

pBe · 发表于 2022-7-6 10:33:18

使用Alanjt sub的示例

copy

 
(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)
   )
 )

希望这有帮助

Tunnelrat · 发表于 2022-7-6 10:39:41

我现在开始工作了
谢谢pBe

alanjt · 发表于 2022-7-6 10:54:19

只是为了好玩。。。

copy

(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)
)

[编程交流] 请帮助为t添加一个选项

发表回复

精选推荐