广告：把块内标注_dimlinear _dimaligned移出块

自贡黄明儒

同一块，如果有多个，每个块标注太麻烦。但如果是镜向的，标注看起来是倒过来的，确实不爽。

根据老迈建议，把标注移出块
下面是主程序（只有主程序）

1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   
2. ;;[功能]将块内标注在块外重新生成
   
3. ;;只重生块内_dimlinear _dimaligned，其余标注删除
   
4. ;;将块内(0 0)转到世界坐标系(MAT:TransNested '(0 0) (list e) 2 0)
   
5. ;;第1步，找到块内标注，假如只有一个，并删除(vla-delete (vlax-ename->vla-object (car (nentsel))))
   
6. ;;第2步，所有同名块列表
   
7. ;;第3步，找到标注的三个点
   
8. ;;第4步，分别把三个对各块转换，重新生成标注
   
9. (defun C:RD (/ E EN NAME SS)
   
10.   (vl-cmdf "._ucs" "");以简化程序
    
11.   (while (setq ss (LM:ssget "\n >选择块<移出块内标注>:" '(((0 . "INSERT")))))
    
12.     (setq e (ssname ss 0))
    
13.     (setq en (entget e))
    
14.     (setq name (cdr (assoc 2 en)))
    
15.     (setq ss (ssget "X" (list '(0 . "INSERT") (cons 2 name))))
    
16.     (_HH:RD ss name)
    
17.   )
    
18.   (princ"\n 重生块内_dimlinear _dimaligned，其余标注删除")
    
19.   (princ)
    
20. )
    
21. (princ"\n 命令:RD,重生块内_dimlinear _dimaligned，其余标注删除")
    
22. (princ)
    
23. 
    
24. (defun _HH:RD (ss name / B1 B1DEL EN FLAG L P1 P2 P3 str1)
    
25.   (setq b1 (TBLOBJNAME "block" name))
    
26.   ;;第1步，找到块内标注，假如只有一个，并删除(vla-delete (vlax-ename->vla-object (car (nentsel))))
    
27.   (setq Flag T)
    
28.   (while (and Flag (setq b1 (entnext b1)))
    
29.     (setq en (entget b1))
    
30.     (setq name (cdr (assoc 0 en)))
    
31.     (if  (wcmatch name "*DIMENSION")
    
32.       (progn
    
33.   (setq Flag nil)
    
34.   (setq b1Del b1)
    
35.       )
    
36.     )
    
37.   )
    
38.   (if (not (wcmatch name "*DIMENSION"))
    
39.     (alert "块内没有标注")
    
40.     (progn
    
41.       (setq name (cdr (assoc 2 en)))  ;块名
    
42.       (setq b1 (TBLOBJNAME "block" name))
    
43.       ;;第3步，找到标注的三个点
    
44.       (setq Flag T)
    
45.       (while (and Flag (setq b1 (entnext b1)))
    
46.   (setq en (entget b1))
    
47.   (if (= (cdr (assoc 0 en)) "MTEXT")
    
48.     (progn
    
49.       ;;非等比块要改为假尺寸
    
50.       (setq str1 (cdr (assoc 1 en)))
    
51.       (setq p1 (cdr (assoc 10 en)))
    
52.       (setq b1 (entnext b1))
    
53.       (setq en (entget b1));第1个"POINT"
    
54.       (setq p2 (cdr (assoc 10 en)))
    
55.       (setq b1 (entnext b1))
    
56.       (setq en (entget b1));第2个"POINT"
    
57.       (setq p3 (cdr (assoc 10 en)))
    
58.       (setq Flag nil)
    
59.     )
    
60.   )
    
61.       )
    
62.     )
    
63.   )
    
64.   
    
65.   (if (and (vl-consp p1) (vl-consp p2) (vl-consp p3))
    
66.     (progn
    
67.       ;;选择集转为vla列表
    
68.       (setq L (LM:ss->vla ss))
    
69.       (vla-delete (vlax-ename->vla-object b1Del));删除块内对象
    
70.       (mapcar (function (lambda(x) (vla-update x))) L )
    
71.       (_HH:RD:do p1 p2 p3 L str1)
    
72.     )
    
73.     (prompt "\n ......标注异常，没找到标注的3个定位点")
    
74.   )
    
75. )
    

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> ;;[功能]将块内标注在块外重新生成<br /> ;;只重生块内_dimlinear _dimaligned，其余标注删除<br /> ;;将块内(0 0)转到世界坐标系(MAT:TransNested '(0 0) (list e) 2 0)<br /> ;;第1步，找到块内标注，假如只有一个，并删除(vla-delete (vlax-ename->vla-object (car (nentsel))))<br /> ;;第2步，所有同名块列表<br /> ;;第3步，找到标注的三个点<br /> ;;第4步，分别把三个对各块转换，重新生成标注<br /> (defun C:RD (/ E EN NAME SS)<br />   (vl-cmdf "._ucs" "");以简化程序<br />   (while (setq ss (LM:ssget "\n >选择块<移出块内标注>:" '(((0 . "INSERT")))))<br />     (setq e (ssname ss 0))<br />     (setq en (entget e))<br />     (setq name (cdr (assoc 2 en)))<br />     (setq ss (ssget "X" (list '(0 . "INSERT") (cons 2 name))))<br />     (_HH:RD ss name)<br />   )<br />   (princ"\n 重生块内_dimlinear _dimaligned，其余标注删除")<br />   (princ)<br /> )<br /> (princ"\n 命令:RD,重生块内_dimlinear _dimaligned，其余标注删除")<br /> (princ)<br /> <br /> (defun _HH:RD (ss name / B1 B1DEL EN FLAG L P1 P2 P3 str1)<br />   (setq b1 (TBLOBJNAME "block" name))<br />   ;;第1步，找到块内标注，假如只有一个，并删除(vla-delete (vlax-ename->vla-object (car (nentsel))))<br />   (setq Flag T)<br />   (while (and Flag (setq b1 (entnext b1)))<br />     (setq en (entget b1))<br />     (setq name (cdr (assoc 0 en)))<br />     (if  (wcmatch name "*DIMENSION")<br />       (progn<br />   (setq Flag nil)<br />   (setq b1Del b1)<br />       )<br />     )<br />   )<br />   (if (not (wcmatch name "*DIMENSION"))<br />     (alert "块内没有标注")<br />     (progn<br />       (setq name (cdr (assoc 2 en)))  ;块名<br />       (setq b1 (TBLOBJNAME "block" name))<br />       ;;第3步，找到标注的三个点<br />       (setq Flag T)<br />       (while (and Flag (setq b1 (entnext b1)))<br />   (setq en (entget b1))<br />   (if (= (cdr (assoc 0 en)) "MTEXT")<br />     (progn<br />       ;;非等比块要改为假尺寸<br />       (setq str1 (cdr (assoc 1 en)))<br />       (setq p1 (cdr (assoc 10 en)))<br />       (setq b1 (entnext b1))<br />       (setq en (entget b1));第1个"POINT"<br />       (setq p2 (cdr (assoc 10 en)))<br />       (setq b1 (entnext b1))<br />       (setq en (entget b1));第2个"POINT"<br />       (setq p3 (cdr (assoc 10 en)))<br />       (setq Flag nil)<br />     )<br />   )<br />       )<br />     )<br />   )<br />   <br />   (if (and (vl-consp p1) (vl-consp p2) (vl-consp p3))<br />     (progn<br />       ;;选择集转为vla列表<br />       (setq L (LM:ss->vla ss))<br />       (vla-delete (vlax-ename->vla-object b1Del));删除块内对象<br />       (mapcar (function (lambda(x) (vla-update x))) L )<br />       (_HH:RD:do p1 p2 p3 L str1)<br />     )<br />     (prompt "\n ......标注异常，没找到标注的3个定位点")<br />   )<br /> )<br />

你有种再说一遍

建议不要做块,而是制作索引和选择集事件,通过事件获取索引,这样就能不修改显示驱动下实现这个功能.
简而言之自己实现了"组块"
那么怎么保存索引呢?制作一个bson,把索引保存进去,把dwg保存在末尾...

自贡黄明儒

你有种再说一遍 发表于 2024-5-30 16:10
建议不要做块,而是制作索引和选择集事件,通过事件获取索引,这样就能不修改显示驱动下实现这个功能.
简而言 ...

这种高级方法只有靠您了

guosheyang

感谢黄大师的分享！

lingduwx

这个程序非常的实用，可否麻烦黄大师整一个完整的Lsp或fas呢，让我们这些普通的不懂lsp也能用上，谢谢黄大师了

panliang9

黄工，下面这个删所有标主的程序能不能改成把所有标注移出块

http://bbs.mjtd.com/thread-188717-1-1.html

自贡黄明儒

panliang9 发表于 2024-5-31 12:09
黄工，下面这个删所有标主的程序能不能改成把所有标注移出块

http://bbs.mjtd.com/thread-188717-1-1.ht ...

删除容易，遍历块，再遍历块成员，发现是标注，删除就行了。

panliang9

我现在把所有标注移出块，都是先用下面这个程序把所有标注移到一个层上，然后锁死该层，再将所有块炸开，标注因为是在锁死层上，就移到外面了。

lingduwx

找到一个工具只能一个一个的选，黄大师的能一次一道块外面，真的是非常厉害