块属性输出到excel

admin

1. ;;; ===============================================
2. ;;; 《块属性输出到excel》
3. ;;; 作者：langjs      命令:atoe  
4. ;;; ===============================================
5. (defun c:atoe (/ active-sheet appxls ash cell col default elist ename ent i intcol j loop lst lst1 lst2
6.                  msxl-xl24hourclock n na name name0 newbook newitem newsheet nu numrow obj out path relcol relrow rng row
7.                  ss ss0 str tlb tlbfile tlbver ty xlcontinuous xlscells xlsworkbooks
8.               )                        ;  加载excel类型库
9.   (defun dsx-typelib-excel (/ path tlb)
10.     (setq obj (vlax-create-object "Excel.Application"))
11.     (setq path (vlax-get-property obj 'path))
12.     (cond
13.       ((setq tlb (findfile (strcat path "\\Excel8.olb")))
14.         tlb
15.       )
16.       ((setq tlb (findfile (strcat path "\\Excel9.olb")))
17.         tlb
18.       )
19.       ((setq tlb (findfile (strcat path "\\Excel10.olb")))
20.         tlb
21.       )
22.       ((setq tlb (findfile (strcat path "\\Excel.exe")))
23.         tlb
24.       )
25.       (t
26.         (alert "本系统内未找到EXCEL97、2000、2002、2003、2010，初始化失败！")
27.       )
28.     )
29.   )                                    ; 定义类型库接口
30.   (defun dsx-load-typelib-excel (/ tlbfile tlbver out)
31.     (cond
32.       ((null msxl-xl24hourclock)
33.         (if (setq tlbfile (dsx-typelib-excel)) ; 加载excel类型库
34.           (progn
35.             (setq tlbver (substr (vl-filename-base tlbfile) 1 6))
36.             (cond
37.               ((= tlbver "10")
38.                 (princ "\n初始化 Microsoft Excel 2002...")
39.               )
40.               ((= tlbver "9")
41.                 (princ "\n初始化 Microsoft Excel 2000...")
42.               )
43.               ((= tlbver "8")
44.                 (princ "\n初始化 Microsoft Excel 97...")
45.               )
46.               ((= (vl-filename-base tlbfile) "Excel")
47.                 (princ "\n初始化 Microsoft Excel ...")
48.               )
49.             )
50.             (vlax-import-type-library :tlb-filename tlbfile :methods-prefix "msxl-" :properties-prefix "msxl-"
51.                                       :constants-prefix "msxl-"
52.             )
53.             (if msxl-xl24hourclock
54.               (setq out t)
55.             )
56.           )
57.         )
58.       )
59.       (t
60.         (setq out t)
61.       )
62.     )
63.     out
64.   )                                    ; 为选中的范围的实行自动调整宽度
65.   (defun dsx-excel-rangeautofit (active-sheet)
66.     (vlax-invoke-method (vlax-get-property (vlax-get-property (vlax-get-property active-sheet 'usedrange) 'cells)
67.                                            'columns
68.                         ) 'autofit
69.     )
70.   )                                    ; 为选中的范围的实行网格线（自加）
71.   (defun dsx-excel-gridline (active-sheet)
72.     (vlax-invoke-method (vlax-get-property (vlax-get-property (vlax-get-property active-sheet 'usedrange) 'cells)
73.                                            'columns
74.                         ) 'borderaround xlcontinuous default 1
75.     )
76.   )                                    ; 为指定单元格填入颜色 (dsx-excel-put-cellcolor 1 1 14)
77.                                        ; 将颜色#14填入到单元格(1,a)
78.   (defun dsx-excel-put-cellcolor (row col intcol / rng)
79.     (setq rng (dsx-excel-get-cell ash row col))
80.     (msxl-put-colorindex (msxl-get-interior rng) intcol)
81.   )                                    ; 在活动的工作表中的单个单元格中获取数据; 获取行列范围内的单元格对象
82.   (defun dsx-excel-get-cell (rng relrow relcol)
83.     (vlax-variant-value (msxl-get-item (msxl-get-cells rng) (vlax-make-variant relrow) (vlax-make-variant relcol)))
84.   )
85.   (defun data2cell (cell numrow col str) ; 写excel
86.     (vlax-put-property cell "item" numrow col (vl-princ-to-string str))
87.   )
88.   (defun celltext (cell nu)            ; 把某一行或者列设置成文本各自nu"a:a"
89.     (vlax-put-property (msxl-get-range cell nu) "NumberFormat" (vlax-make-variant "@"))
90.   )
91.   (defun initexcel ()
92.     (dsx-load-typelib-excel)
93.     (setq appxls (vlax-get-or-create-object "excel.application")
94.           xlsworkbooks (vlax-get-property appxls "workbooks")
95.           newbook (vlax-invoke-method xlsworkbooks "add")
96.           newsheet (vlax-get-property newbook "sheets")
97.           newitem (vlax-get-property newsheet "item" 1)
98.           xlscells (vlax-get-property newitem "cells")
99.           ash (msxl-get-activesheet appxls)
100.     )
101.     (vla-put-visible appxls :vlax-true)
102.   )
103.   (defun endexcel ()
104.     (vlax-release-object xlscells)
105.     (vlax-release-object newitem)
106.     (vlax-release-object newsheet)
107.     (vlax-release-object newbook)
108.     (vlax-release-object xlsworkbooks)
109.     (vlax-release-object appxls)
110.   )
111.   (defun #err (s)
112.     (setvar "nomutt" 0)
113.     (if name0
114.       (redraw name0 4)
115.     )
116.     (setq *error* $orr)
117.   )
118.   (setq $orr *error*)
119.   (setq *error* #err)
120.   (vl-load-com)
121.   (setvar "cmdecho" 0)                 ; 关闭命令响应
122.   (setvar "nomutt" 1)
123.   (princ "\n 属性转EXCEL")
124.   (princ "\n选择属性块:")
125.   (while (not (and
126.                 (setq ss0 (ssget ":E:S" (list '(0 . "insert") '(66 . 1))))
127.                 (setq name0 (ssname ss0 0))
128.                 (setq ent (entget name0))
129.                 (setq na (assoc 2 ent))
130.               )
131.          )
132.     (if (= 52 (getvar "errno"))
133.       (vl-exit-with-error "")
134.     )
135.   )
136.   (if ss0
137.     (progn
138.       (redraw name0 3)
139.       (princ "\n框选属性块:")
140.       (setq ss (ssget (list '(0 . "INSERT") na '(66 . 1))))
141.       (if (not ss)
142.         (setq ss ss0)
143.       )
144.       (redraw name0 4)
145.       (setq ss (ssadd name0 ss))
146.       (setq lst '())
147.       (repeat (setq i (sslength ss))
148.         (setq name (ssname ss (setq i (1- i))))
149.         (setq ent (entget name))
150.         (setq ty (cdr (assoc 2 ent)))
151.         (setq ename (entnext name))
152.         (setq loop t)
153.         (setq lst1 '())
154.         (setq lst2 '())
155.         (while (and
156.                  ename
157.                  loop
158.                )
159.           (setq elist (entget ename))
160.           (if (= (cdr (assoc 0 elist)) "ATTRIB")
161.             (progn
162.               (setq lst1 (cons (cdr (assoc 1 elist)) lst1))
163.               (setq lst2 (cons (cdr (assoc 2 elist)) lst2))
164.             )
165.             (setq loop nil)
166.           )
167.           (setq ename (entnext ename))
168.         )
169.         (setq lst (cons (reverse lst1) lst))
170.       )
171.       (setq lst (cons (reverse lst2) lst))
172.       (initexcel)
173.       (celltext xlscells "B:B")
174.       (setq i 1)
175.       (foreach lst1 lst
176.         (setq j 1)
177.         (foreach n lst1
178.           (data2cell xlscells i j n)   ;    (dsx-excel-get-cell ash i j)
179.                                        ;    (dsx-excel-gridline ash)
180.           (setq j (1+ j))
181.         )
182.         (setq i (1+ i))
183.       )
184.       (dsx-excel-rangeautofit ash)
185.       (dsx-excel-gridline ash)
186.       (setq i 0)
187.       (repeat (length lst2)
188.         (dsx-excel-put-cellcolor 1 (setq i (1+ i))
189.                                  6
190.         )
191.       )
192.       (endexcel)
193.     )
194.   )
195.   (setvar "nomutt" 0)
196.   (princ)
197. )

复制代码