[源码] 《属性表替换属性表》

admin

1. ;;; ===============================================
2. ;;; 《属性表替换属性表》
3. ;;; 作者：langjs      命令:attatt
4. ;;; ===============================================
5. (defun c:atoa (/ elist ename ent ent1 h i j loop lst lst1 lst2 maxpoint minpoint na name name0 name1 nub p0 pmax pmin pt
6.                  pt1 pt10 pt2 r snap ss ss0 ss1 str w x y
7.               )
8.   (defun wratt (ent nub str / box ent1 h i j pt pt1 pt10 pt2 w) ; 写属性块
9.     (defun jspt (pt i j)               ; pt相对坐标计算
10.       (list (+ (car pt) i) (+ (cadr pt) j))
11.     )
12.     (defun sub (ent i str)
13.       (subst
14.         (cons i str)
15.         (assoc i ent)
16.         ent
17.       )
18.     )
19.     (setq ent1 ent)
20.     (while (= (cdr (assoc 0 (setq ent1 (entget (entnext (cdr (assoc -1 ent1))))))) "ATTRIB")
21.       (if (= (cdr (assoc 2 ent1)) nub)
22.         (progn
23.           (setq pt10 (cdr (assoc 10 ent1)))
24.           (setq h (cdr (assoc 40 ent1)))
25.           (setq w 0.7)
26.           (setq ent1 (sub ent1 41 w))
27.           (setq ent1 (sub ent1 1 str))
28.           (if (and
29.                 (setq box (textbox (cdr ent1)))
30.                 (= (cdr (assoc 72 ent1)) 0)
31.               )
32.             (progn
33.               (setq pt1 (jspt pt10 (car (car box)) (* 0.5 (cadr (cadr box)))))
34.               (setq pt2 (jspt pt10 (car (cadr box)) (* 0.5 (cadr (cadr box)))))
35.               (entmod (sub ent1 1 ""))
36.               (entmod ent)
37.               (while (and
38.                        (ssget "F" (list pt1 pt2) '((0 . "INSERT,LINE")))
39.                        (> (car pt2) (car pt1))
40.                      )
41.                 (setq w (- w 0.01))
42.                 (setq ent1 (sub ent1 41 w))
43.                 (setq box (textbox (cdr ent1)))
44.                 (setq pt2 (jspt pt10 (car (cadr box)) (* 0.5 (cadr (cadr box)))))
45.               )
46.             )
47.           )
48.           (entmod ent1)
49.         )
50.       )
51.     )
52.     (entmod ent)
53.   )
54.   (defun #err (s)
55.     (setvar "nomutt" 0)
56.     (setvar "osmode" snap)
57.     (if name0
58.       (redraw name0 4)
59.     )
60.     (setq *error* $orr)
61.   )
62.   (vl-load-com)
63.   (setq $orr *error*)
64.   (setq *error* #err)
65.   (setvar "cmdecho" 0)
66.   (setq snap (getvar "osmode"))
67.   (setvar "nomutt" 1)
68.   (setq ss (ssadd))
69.   (princ "\n选择源属性块样式:")
70.   (if (setq ss0 (ssget ":E:S" (list '(0 . "insert") '(66 . 1))))
71.     (progn
72.       (setq name0 (ssname ss0 0))
73.       (setq ent (entget name0))
74.       (setq na (assoc 2 ent))
75.       (redraw name0 3)
76.       (princ "\n框选源属性块：")
77.       (if (setq ss1 (ssget (list '(0 . "INSERT") na '(66 . 1))))
78.         (setq ss (ssadd name0 ss1))
79.         (setq ss (ssadd name0 ss))
80.       )
81.       (redraw name0 4)
82.       (setq lst '())
83.       (repeat (setq i (sslength ss))
84.         (setq name (ssname ss (setq i (1- i))))
85.         (setq ent (entget name))
86.         (setq ename (entnext name))
87.         (setq loop t)
88.         (setq lst1 '())
89.         (while (and
90.                  ename
91.                  loop
92.                )
93.           (setq elist (entget ename))
94.           (if (= (cdr (assoc 0 elist)) "ATTRIB")
95.             (progn
96.               (setq lst1 (cons (list (cdr (assoc 2 elist)) (cdr (assoc 1 elist))) lst1))
97.             )
98.             (setq loop nil)
99.           )
100.           (setq ename (entnext ename))
101.         )
102.         (setq lst (cons (reverse lst1) lst))
103.       )
104.       (setq lst (vl-sort lst (function (lambda (x y)
105.                                          (< (atoi (cadr (car x))) (atoi (cadr (car y))))
106.                                        )
107.                              )
108.                 )
109.       )
110.       (princ "\n选择目标属性块样式：")
111.       (if (setq name (car (entsel)))
112.         (progn
113.           (vla-getboundingbox (vlax-ename->vla-object name) 'minpoint 'maxpoint)
114.           (setq pmax (vlax-safearray->list maxpoint)
115.                 pmin (vlax-safearray->list minpoint)
116.           )
117.           (setq x (- (car pmax) (car pmin))
118.                 y (- (cadr pmax) (cadr pmin))
119.           )
120.           (setq ent (entget name))
121.           (setq na (cdr (assoc 1 ent)))
122.           (setq p0 (cdr (assoc 10 ent)))
123.           (princ "\n输入插入点：")
124.           (if (setq pt (getpoint))
125.             (progn
126.               (setvar "osmode" 0)
127.               (princ "\n指定排序方向：")
128.               (if (setq pt1 (getpoint pt))
129.                 (progn
130.                   (setq r (/ (* 180.0 (angle pt pt1)) pi))
131.                   (cond
132.                     ((< r 45)
133.                       (setq y 0)
134.                     )
135.                     ((< r 135)
136.                       (setq x 0)
137.                     )
138.                     ((< r 225)
139.                       (setq x (* -1 x)
140.                             y 0
141.                       )
142.                     )
143.                     ((< r 315)
144.                       (setq x 0
145.                             y (* -1 y)
146.                       )
147.                     )
148.                     (t
149.                       (setq y 0)
150.                     )
151.                   )
152.                   (foreach lst1 lst
153.                     ((if command-s
154.                        command-s
155.                        vl-cmdf
156.                      ) "copy"
157.                      name ""
158.                      p0 pt
159.                     )
160.                     (setq name1 (entlast))
161.                     (setq ent (entget name1))
162.                     (setq ent1 ent)
163.                     (while (= (cdr (assoc 0 (setq ent1 (entget (entnext (cdr (assoc -1 ent1))))))) "ATTRIB")
164.                       (entmod (subst
165.                                 (cons 1 "")
166.                                 (assoc 1 ent1)
167.                                 ent1
168.                               )
169.                       )
170.                     )
171.                     (entmod ent)
172.                     (setq ent (entget name1))
173.                     (foreach lst2 lst1
174.                       (wratt ent (car lst2) (cadr lst2))
175.                     )
176.                     (setq pt (list (+ (car pt) x) (+ (cadr pt) y)))
177.                   )
178.                 )
179.               )
180.             )
181.           )
182.         )
183.       )
184.     )
185.   )
186.   (setvar "nomutt" 0)
187.   (setvar "osmode" snap)
188.   (setq *error* $orr)
189.   (princ)
190. )

复制代码