块属性输出到excel
(defun c:atoe (/ active-sheet appxls ash cell col default elist ename ent i intcol j loop lst lst1 lst2msxl-xl24hourclock n na name name0 newbook newitem newsheet nu numrow obj out path relcol relrow rng row
ss ss0 str tlb tlbfile tlbver ty xlcontinuous xlscells xlsworkbooks
) ;加载excel类型库
(defun dsx-typelib-excel (/ path tlb)
(setq obj (vlax-create-object "Excel.Application"))
(setq path (vlax-get-property obj 'path))
(cond
((setq tlb (findfile (strcat path "\\Excel8.olb")))
tlb
)
((setq tlb (findfile (strcat path "\\Excel9.olb")))
tlb
)
((setq tlb (findfile (strcat path "\\Excel10.olb")))
tlb
)
((setq tlb (findfile (strcat path "\\Excel.exe")))
tlb
)
(t
(alert "本系统内未找到EXCEL97、2000、2002、2003、2010，初始化失败！")
)
)
) ; 定义类型库接口
(defun dsx-load-typelib-excel (/ tlbfile tlbver out)
(cond
((null msxl-xl24hourclock)
(if (setq tlbfile (dsx-typelib-excel)) ; 加载excel类型库
(progn
(setq tlbver (substr (vl-filename-base tlbfile) 1 6))
(cond
((= tlbver "10")
(princ "\n初始化 Microsoft Excel 2002...")
)
((= tlbver "9")
(princ "\n初始化 Microsoft Excel 2000...")
)
((= tlbver "8")
(princ "\n初始化 Microsoft Excel 97...")
)
((= (vl-filename-base tlbfile) "Excel")
(princ "\n初始化 Microsoft Excel ...")
)
)
(vlax-import-type-library :tlb-filename tlbfile :methods-prefix "msxl-" :properties-prefix "msxl-"
:constants-prefix "msxl-"
)
(if msxl-xl24hourclock
(setq out t)
)
)
)
)
(t
(setq out t)
)
)
out
) ; 为选中的范围的实行自动调整宽度
(defun dsx-excel-rangeautofit (active-sheet)
(vlax-invoke-method (vlax-get-property (vlax-get-property (vlax-get-property active-sheet 'usedrange) 'cells)
'columns
) 'autofit
)
) ; 为选中的范围的实行网格线（自加）
(defun dsx-excel-gridline (active-sheet)
(vlax-invoke-method (vlax-get-property (vlax-get-property (vlax-get-property active-sheet 'usedrange) 'cells)
'columns
) 'borderaround xlcontinuous default 1
)
) ; 为指定单元格填入颜色 (dsx-excel-put-cellcolor 1 1 14)
; 将颜色#14填入到单元格(1,a)
(defun dsx-excel-put-cellcolor (row col intcol / rng)
(setq rng (dsx-excel-get-cell ash row col))
(msxl-put-colorindex (msxl-get-interior rng) intcol)
) ; 在活动的工作表中的单个单元格中获取数据; 获取行列范围内的单元格对象
(defun dsx-excel-get-cell (rng relrow relcol)
(vlax-variant-value (msxl-get-item (msxl-get-cells rng) (vlax-make-variant relrow) (vlax-make-variant relcol)))
)
(defun data2cell (cell numrow col str) ; 写excel
(vlax-put-property cell "item" numrow col (vl-princ-to-string str))
)
(defun celltext (cell nu) ; 把某一行或者列设置成文本各自nu"a:a"
(vlax-put-property (msxl-get-range cell nu) "NumberFormat" (vlax-make-variant "@"))
)
(defun initexcel ()
(dsx-load-typelib-excel)
(setq appxls (vlax-get-or-create-object "excel.application")
xlsworkbooks (vlax-get-property appxls "workbooks")
newbook (vlax-invoke-method xlsworkbooks "add")
newsheet (vlax-get-property newbook "sheets")
newitem (vlax-get-property newsheet "item" 1)
xlscells (vlax-get-property newitem "cells")
ash (msxl-get-activesheet appxls)
)
(vla-put-visible appxls :vlax-true)
)
(defun endexcel ()
(vlax-release-object xlscells)
(vlax-release-object newitem)
(vlax-release-object newsheet)
(vlax-release-object newbook)
(vlax-release-object xlsworkbooks)
(vlax-release-object appxls)
)
(defun #err (s)
(setvar "nomutt" 0)
(if name0
(redraw name0 4)
)
(setq *error* $orr)
)
(setq $orr *error*)
(setq *error* #err)
(vl-load-com)
(setvar "cmdecho" 0) ; 关闭命令响应
(setvar "nomutt" 1)
(princ "\n 属性转EXCEL")
(princ "\n选择属性块:")
(while (not (and
(setq ss0 (ssget ":E:S" (list '(0 . "insert") '(66 . 1))))
(setq name0 (ssname ss0 0))
(setq ent (entget name0))
(setq na (assoc 2 ent))
)
)
(if (= 52 (getvar "errno"))
(vl-exit-with-error "")
)
)
(if ss0
(progn
(redraw name0 3)
(princ "\n框选属性块:")
(setq ss (ssget (list '(0 . "INSERT") na '(66 . 1))))
(if (not ss)
(setq ss ss0)
)
(redraw name0 4)
(setq ss (ssadd name0 ss))
(setq lst '())
(repeat (setq i (sslength ss))
(setq name (ssname ss (setq i (1- i))))
(setq ent (entget name))
(setq ty (cdr (assoc 2 ent)))
(setq ename (entnext name))
(setq loop t)
(setq lst1 '())
(setq lst2 '())
(while (and
ename
loop
)
(setq elist (entget ename))
(if (= (cdr (assoc 0 elist)) "ATTRIB")
(progn
(setq lst1 (cons (cdr (assoc 1 elist)) lst1))
(setq lst2 (cons (cdr (assoc 2 elist)) lst2))
)
(setq loop nil)
)
(setq ename (entnext ename))
)
(setq lst (cons (reverse lst1) lst))
)
(setq lst (cons (reverse lst2) lst))
(initexcel)
(celltext xlscells "B:B")
(setq i 1)
(foreach lst1 lst
(setq j 1)
(foreach n lst1
(data2cell xlscells i j n) ; (dsx-excel-get-cell ash i j)
; (dsx-excel-gridline ash)
(setq j (1+ j))
)
(setq i (1+ i))
)
(dsx-excel-rangeautofit ash)
(dsx-excel-gridline ash)
(setq i 0)
(repeat (length lst2)
(dsx-excel-put-cellcolor 1 (setq i (1+ i))
6
)
)
(endexcel)
)
)
(setvar "nomutt" 0)
(princ)
)
页:
[1]