[分享]将块的一些信息提取到EXCEL

citykunan

前不久从台湾买了一本书，其中有一个将块的一些信息提取到EXCEL的程序很不错，拿来与诸位分享。这个范例不错，至少我能看懂。：） (defun c:blk2xls (/ apl-exit initexcel endexcel datacell dorow dotable appxls
xlsworkbooks newbook newsheet newitem xlscells objs count
ent claves numrow title blkss blksub blk_qty k0 i0 blkname
xscale yscale zscale rotang
blkdxf numcol insert0)
;;;1.定义离开函数
(defun apl-exit (msg)
(endexcel)
(prompt msg)
(setq *error* oer)
)
;;;2.initexcel用来初始M Excel
(defun initexcel ()
(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")
)
(vla-put-visible appxls :vlax-true)
)
;;;3.endexcel用来释放excel
(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)
)
;;;4.datacell将value填入numrow,col的格子中
(defun datacell (nurow col value)
(vlax-put-property xlscells "item" numrow col (vl-princ-to-string value))
)
(setq oer *error*
*error* apl-exit
)
(vl-load-com)
(initexcel)
(setq numrow 1 numcol 0)
;;;5.列出表头
(datacell numrow (setq numcol (1+ numcol)) "Bock name")
(datacell numrow (setq numcol (1+ numcol)) "X scale")
(datacell numrow (setq numcol (1+ numcol)) "Y scale")
(datacell numrow (setq numcol (1+ numcol)) "Z scale")
(datacell numrow (setq numcol (1+ numcol)) "Angle")
(datacell numrow (setq numcol (1+ numcol)) "Number")
;;;6.依次处理各图块的参考
(setq blkdxf (tblnext "BLOCK" t))
(while blkdxf ;while1
(setq blkname (cdr (assoc 2 blkdxf))
blkss (ssget "x" (list (cons 0 "INSERT") (cons 2 blkname)))
)
(setq i0 0)
(if blkss
(setq blkss_qty (sslength blkss)) ;写出块的数量
(setq blkss_qty 0);图面上没有这个块则数量为0
)
(while (< i0 blkss_qty) ;while2 ;当有这个图块时;;;7.依条件建立图块参考的选集
(setq insert0 (ssname blkss i0)
xscale (cdr (assoc 41 (entget insert0)))
yscale (cdr (assoc 42 (entget insert0)))
zscale (cdr (assoc 43 (entget insert0)))
rotang (cdr (assoc 50 (entget insert0)))
blksub (ssget "x" (list (cons 0 "INSERT")
(cons 2 blkname)
(cons 41 xscale)
(cons 42 yscale)
(cons 43 zscale)
(cons 50 rotang)))
blkss_qty (- blkss_qty (sslength blksub))
numrow (1+ numrow)
numcol 0
k0 0
)
(while (< k0 (sslength blksub)) ;while3
(setq blkss (ssdel (ssname blksub k0) blkss))
(setq k0 (1+ k0))
);end whlie3
;;;8.写入资料
(datacell numrow (setq numcol (1+ numcol)) blkname)
(datacell numrow (setq numcol (1+ numcol)) (rtos xscale))
(datacell numrow (setq numcol (1+ numcol)) (rtos yscale))
(datacell numrow (setq numcol (1+ numcol)) (rtos zscale))
(datacell numrow (setq numcol (1+ numcol)) (rtos (* 180 (/ rotang pi))))
(datacell numrow (setq numcol (1+ numcol)) (rtos (sslength blksub) 2 0))
);end while2
(setq blkdxf (tblnext "BLOCK"))
);END WHILE1 (endexcel)
(setq *error* oer)
(princ)
)

白色微風1991

學習了，多謝分享！！

hushengjun

什么书，很不错

qyming

书名是什么？？？？？？？？

yjr111

搞了半天，还是这个最实用易懂，最简洁！

langjs

确实不错的说

vlisp2012

学习了，多谢分享！！

zhouren_cmi

2005年就有了，但偶才看到，谢谢分享

springwillow

过来学习，版主辛苦了！

lohas1118

学习了，多谢分享！！

hoot6335

很好  我真好需要