[源码] 《读取excel写入块属性》

admin

1. ;;; ===============================================
2. ;;; 《读取excel写入块属性》
3. ;;; 作者：langjs      命令:etoa
4. ;;; ===============================================
5. (defun c:etoa (/ appsession box cells ent ent1 fil h i j lst lst1 lst2 maxpoint minpoint na name name0 name1 nub oldfil
6.                  p0 pmax pmin pt pt1 pt10 pt2 r snap ss 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 rexcel (cells i j)            ; 读取excel第i行第j列
55.     (vlax-variant-value (vlax-variant-change-type (vlax-get-property cells 'item i j) 8))
56.   )
57.   (defun #err (s)
58.     (setvar "nomutt" 0)
59.     (setvar "osmode" snap)
60.     (if name
61.       (redraw name 4)
62.     )
63.     (setq *error* $orr)
64.   )
65.   (vl-load-com)
66.   (setq $orr *error*)
67.   (setq *error* #err)
68.   (setvar "cmdecho" 0)
69.   (setq snap (getvar "osmode"))
70.   (if (null oldfil)
71.     (setq oldfil (vl-filename-directory (findfile "acad.exe")))
72.   )
73.   (if (/= (substr oldfil (strlen oldfil)) "\")
74.     (setq oldfil (strcat oldfil "\"))
75.   )
76.   (princ "\nEXCEL转属性")
77.   (princ "\n选择EXCEL表:")
78.   (setq fil (getfiled "选择EXCEL数据表" oldfil "xls;xlsx" 0))
79.   (setq oldfil (vl-filename-directory fil))
80.   (setq appsession (vlax-get-or-create-object "Excel.Application"))
81.   (vlax-invoke-method (vlax-get-property appsession 'workbooks) 'open fil)
82.   (vla-put-visible appsession 0)
83.   (setq cells (vlax-get (vlax-get-property (vlax-get-property (vlax-get-object "Excel.Application") 'activeworkbook)
84.                                            'activesheet
85.                         ) "cells"
86.               )
87.   )
88.   (setq j 1
89.         lst '()
90.         lst1 '()
91.   )
92.   (while (/= (setq str (rexcel cells 1 j))
93.              ""
94.          )
95.     (setq lst1 (cons str lst1))
96.     (setq j (1+ j))
97.   )
98.   (setq lst1 (reverse lst1))
99.   (setq i 2)
100.   (while (/= (rexcel cells i 1) "")
101.     (setq j 1
102.           lst2 '()
103.     )
104.     (repeat (length lst1)
105.       (setq str (rexcel cells i j))
106.       (setq lst2 (cons str lst2))
107.       (setq j (1+ j))
108.     )
109.     (setq lst2 (reverse lst2))
110.     (setq lst (cons lst2 lst))
111.     (setq i (1+ i))
112.   )
113.   (setq lst (reverse lst))
114.   (setvar "nomutt" 1)
115.   (setq ss (ssadd))
116.   (if (> (length lst) 0)
117.     (progn
118.       (princ "\n选择属性块样式：")
119.       (if (setq name (car (entsel)))
120.         (progn
121.           (redraw name 3)
122.           (vla-getboundingbox (vlax-ename->vla-object name) 'minpoint 'maxpoint)
123.           (setq pmax (vlax-safearray->list maxpoint)
124.                 pmin (vlax-safearray->list minpoint)
125.           )
126.           (setq x (- (car pmax) (car pmin))
127.                 y (- (cadr pmax) (cadr pmin))
128.           )
129.           (setq ent (entget name))
130.           (setq na (cdr (assoc 1 ent)))
131.           (setq p0 (cdr (assoc 10 ent)))
132.           (princ "\n输入插入点：")
133.           (if (setq pt (getpoint))
134.             (progn
135.               (setvar "osmode" 0)
136.               (princ "\n指定排序方向：")
137.               (if (setq pt1 (getpoint pt))
138.                 (progn
139.                   (setq r (/ (* 180.0 (angle pt pt1)) pi))
140.                   (cond
141.                     ((< r 45)
142.                       (setq y 0)
143.                     )
144.                     ((< r 135)
145.                       (setq x 0)
146.                     )
147.                     ((< r 225)
148.                       (setq x (* -1 x)
149.                             y 0
150.                       )
151.                     )
152.                     ((< r 315)
153.                       (setq x 0
154.                             y (* -1 y)
155.                       )
156.                     )
157.                     (t
158.                       (setq y 0)
159.                     )
160.                   )
161.                   (foreach lst2 lst
162.                     ((if command-s
163.                        command-s
164.                        vl-cmdf
165.                      ) "copy"
166.                      name ""
167.                      p0 pt
168.                     )
169.                     (setq name1 (entlast))
170.                     (setq ent (entget name1))
171.                     (setq ent1 ent)
172.                     (while (= (cdr (assoc 0 (setq ent1 (entget (entnext (cdr (assoc -1 ent1))))))) "ATTRIB")
173.                       (entmod (subst
174.                                 (cons 1 "")
175.                                 (assoc 1 ent1)
176.                                 ent1
177.                               )
178.                       )
179.                     )
180.                     (entmod ent)
181.                     (setq ent (entget name1))
182.                     (setq i 0)
183.                     (repeat (length lst1)
184.                       (setq nub (nth i lst1))
185.                       (setq str (nth i lst2))
186.                       (wratt ent nub str)
187.                       (setq i (1+ i))
188.                     )
189.                     (setq pt (list (+ (car pt) x) (+ (cadr pt) y)))
190.                   )
191.                 )
192.               )
193.             )
194.           )
195.           (redraw name 4)
196.         )
197.       )
198.     )
199.   )
200.   (setvar "nomutt" 0)
201.   (setvar "osmode" snap)
202.   (setq *error* $orr)
203.   (princ)
204. )

复制代码