从块参照内复制图形到指定020划线层

孙玉坤

这是我请社区的的一个老师给编辑的一个小代码，但是考虑不到。所以功能不够完美，最近用的比较多 ，所以就想请社区的那为老师给优化一下代码，本人纯小白。

kozmosovia

你现在的代码根本没有处理块内图形。
新写了一个，最后不需要复制了再删除，直接用移动才好。
块会自动被分解到底。
没有测试

2. (defun c:sx (/ _copy chklay *ERROR*_BAK IDX OBJ SS SSX T-*ERROR*)
   
3.   (defun T-*error* (msg)
   
4.     (and ssx (vl-cmdf "_.erase" ssx "")) ;删除图元
   
5.     (setq *error* *error*_bak)
   
6.     (princ)
   
7.   )
   
8.   (defun chklay  (layname col /)
   
9.     (if  (null (tblsearch "layer" layname))
   
10.       (vl-cmdf "-layer" "n" layname "c" col layname "")
    
11.     )
    
12.   )
    
13.   (Defun _copy (ss / IDX OBJ RTN)
    
14.     (setq idx -1)
    
15.     (repeat (sslength ss)
    
16.       (and (setq obj (vl-remove-if
    
17.            (function
    
18.        (lambda (x)
    
19.          (member (car x) (list -1 5 62 420 421))
    
20.        )
    
21.            )
    
22.            (entget (ssname ss (setq idx (1+ idx))))
    
23.          )
    
24.      obj (entmakex (subst (cons 8 "020划线") (assoc 8 obj) obj))
    
25.      )
    
26.      (if (= (cdr (assoc 0 (entget obj))) "INSERT")
    
27.        (setq obj (vl-cmdf "_.explode" obj)
    
28.        rtn (append rtn (_copy (ssget "_p")))
    
29.        )
    
30.        (setq rtn (cons obj rtn))
    
31.      )
    
32.       )
    
33.     )
    
34.     rtn
    
35.   )
    
36.   (setq  *error*_bak
    
37.    *error*
    
38.   *error*  T-*error*
    
39.   )
    
40.   (chklay "020划线" "250")
    
41.   (and (setq ss (ssget))
    
42.        (setq ss (_Copy ss))
    
43.        (setq ssx (ssadd))
    
44.        (progn (foreach abc ss (ssadd abc ssx))
    
45.         (vl-cmdf "_.Move" ssx "" pause pause "") ;复制
    
46.        )
    
47.   )
    
48.   (princ)
    
49. )
    

(defun c:sx (/ _copy chklay *ERROR*_BAK IDX OBJ SS SSX T-*ERROR*)<br />   (defun T-*error* (msg)<br />     (and ssx (vl-cmdf "_.erase" ssx "")) ;删除图元<br />     (setq *error* *error*_bak)<br />     (princ)<br />   )<br />   (defun chklay  (layname col /)<br />     (if  (null (tblsearch "layer" layname))<br />       (vl-cmdf "-layer" "n" layname "c" col layname "")<br />     )<br />   )<br />   (Defun _copy (ss / IDX OBJ RTN)<br />     (setq idx -1)<br />     (repeat (sslength ss)<br />       (and (setq obj (vl-remove-if<br />            (function<br />        (lambda (x)<br />          (member (car x) (list -1 5 62 420 421))<br />        )<br />            )<br />            (entget (ssname ss (setq idx (1+ idx))))<br />          )<br />      obj (entmakex (subst (cons 8 "020划线") (assoc 8 obj) obj))<br />      )<br />      (if (= (cdr (assoc 0 (entget obj))) "INSERT")<br />        (setq obj (vl-cmdf "_.explode" obj)<br />        rtn (append rtn (_copy (ssget "_p")))<br />        )<br />        (setq rtn (cons obj rtn))<br />      )<br />       )<br />     )<br />     rtn<br />   )<br />   (setq  *error*_bak<br />    *error*<br />   *error*  T-*error*<br />   )<br />   (chklay "020划线" "250")<br />   (and (setq ss (ssget))<br />        (setq ss (_Copy ss))<br />        (setq ssx (ssadd))<br />        (progn (foreach abc ss (ssadd abc ssx))<br />         (vl-cmdf "_.Move" ssx "" pause pause "") ;复制<br />        )<br />   )<br />   (princ)<br /> )<br />

pyj643921

最好上传个文件
按自己理解写了一个

孙玉坤

kozmosovia 发表于 2025-8-7 10:05
你现在的代码根本没有处理块内图形。
新写了一个，最后不需要复制了再删除，直接用移动才好。
块会自动被 ...

就是想要的真功能 ，我用了一下 现在的代码就是能复制出图形到指定层 ，但在原图也多复制了一份图形
复制有线宽的图形，  也一起把线宽改为o

xyp1964

没看懂啥意思

孙玉坤

kozmosovia 发表于 2025-8-6 20:23
你现在的代码根本没有处理块内图形。
新写了一个，最后不需要复制了再删除，直接用移动才好。
块会自动被 ...

这段代码能实现想要的效果，就是多复制了一份块本层的图型，是线宽的不能炸开我0宽   大师有时间帮我优化一下

孙玉坤

pyj643921 发表于 2025-8-7 09:52
最好上传个文件
按自己理解写了一个

大师能添加捕捉点就完美了

pyj643921

孙玉坤 发表于 2025-8-12 15:08
大师能添加捕捉点就完美了

本身就可以捕捉的，可能你没开捕捉吧

孙玉坤

pyj643921 发表于 2025-8-12 15:51
本身就可以捕捉的，可能你没开捕捉吧

我怪我没有表达清楚，复制后可以捕捉，  就是原图块不能捕捉移动点，会自动捕捉块中心点

pyj643921

孙玉坤 发表于 2025-8-12 16:22
我怪我没有表达清楚，复制后可以捕捉，  就是原图块不能捕捉移动点，会自动捕捉块中心点

已更新代码，重新下载就可以了。