将块内标注在块外重新生成

nkmjg

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

复制代码