[分享]将块的一些信息提取到EXCEL
前不久从台湾买了一本书，其中有一个将块的一些信息提取到EXCEL的程序很不错，拿来与诸位分享。这个范例不错，至少我能看懂。：）(defun c:blk2xls (/ apl-exit initexcel endexcel datacell dorow dotable appxls<BR> xlsworkbooks newbook newsheet newitem xlscells objs count<BR> ent claves numrow title blkss blksub blk_qty k0 i0 blkname<BR> xscale yscale zscale rotang<BR> blkdxf numcol insert0)<BR> ;;;1.定义离开函数<BR> (defun apl-exit (msg)<BR> (endexcel)<BR> (prompt msg)<BR> (setq *error* oer)<BR> )<BR> ;;;2.initexcel用来初始M Excel<BR> (defun initexcel ()<BR> (setq appxls (vlax-get-or-create-object "excel.application")<BR> xlsworkbooks (vlax-get-property appxls "workbooks")<BR> newbook (vlax-invoke-method xlsworkbooks "add")<BR> newsheet (vlax-get-property newbook "sheets")<BR> newitem (vlax-get-property newsheet "item" 1)<BR> xlscells (vlax-get-property newitem "cells")<BR> )<BR> (vla-put-visible appxls :vlax-true)<BR> )<BR> ;;;3.endexcel用来释放excel<BR> (defun endexcel ()<BR> (vlax-release-object xlscells)<BR> (vlax-release-object newitem)<BR> (vlax-release-object newsheet)<BR> (vlax-release-object newbook)<BR> (vlax-release-object xlsworkbooks)<BR> (vlax-release-object appxls)<BR> )<BR> ;;;4.datacell将value填入numrow,col的格子中<BR> (defun datacell (nurow col value)<BR> (vlax-put-property xlscells "item" numrow col (vl-princ-to-string value))<BR> )<BR> (setq oer *error*<BR> *error* apl-exit<BR> )<BR> (vl-load-com)<BR> (initexcel)<BR> (setq numrow 1 numcol 0)<BR> ;;;5.列出表头<BR> (datacell numrow (setq numcol (1+ numcol)) "Bock name")<BR> (datacell numrow (setq numcol (1+ numcol)) "X scale")<BR> (datacell numrow (setq numcol (1+ numcol)) "Y scale")<BR> (datacell numrow (setq numcol (1+ numcol)) "Z scale")<BR> (datacell numrow (setq numcol (1+ numcol)) "Angle")<BR> (datacell numrow (setq numcol (1+ numcol)) "Number")<BR> ;;;6.依次处理各图块的参考<BR> (setq blkdxf (tblnext "BLOCK" t))<BR> (while blkdxf ;while1<BR> (setq blkname (cdr (assoc 2 blkdxf))<BR> blkss (ssget "x" (list (cons 0 "INSERT") (cons 2 blkname)))<BR> )<BR> (setq i0 0)<BR> (if blkss<BR> (setq blkss_qty (sslength blkss)) ;写出块的数量<BR> (setq blkss_qty 0);图面上没有这个块则数量为0<BR> )<BR> (while (< i0 blkss_qty) ;while2 ;当有这个图块时;;;7.依条件建立图块参考的选集<BR> (setq insert0 (ssname blkss i0)<BR> xscale (cdr (assoc 41 (entget insert0)))<BR> yscale (cdr (assoc 42 (entget insert0)))<BR> zscale (cdr (assoc 43 (entget insert0)))<BR> rotang (cdr (assoc 50 (entget insert0)))<BR> blksub (ssget "x" (list (cons 0 "INSERT")<BR> (cons 2 blkname)<BR> (cons 41 xscale)<BR> (cons 42 yscale)<BR> (cons 43 zscale)<BR> (cons 50 rotang)))<BR> blkss_qty (- blkss_qty (sslength blksub))<BR> numrow (1+ numrow)<BR> numcol 0<BR> k0 0<BR> )<BR> (while (< k0 (sslength blksub)) ;while3<BR> (setq blkss (ssdel (ssname blksub k0) blkss))<BR> (setq k0 (1+ k0))<BR> );end whlie3<BR> ;;;8.写入资料<BR> (datacell numrow (setq numcol (1+ numcol)) blkname)<BR> (datacell numrow (setq numcol (1+ numcol)) (rtos xscale))<BR> (datacell numrow (setq numcol (1+ numcol)) (rtos yscale))<BR> (datacell numrow (setq numcol (1+ numcol)) (rtos zscale))<BR> (datacell numrow (setq numcol (1+ numcol)) (rtos (* 180 (/ rotang pi))))<BR> (datacell numrow (setq numcol (1+ numcol)) (rtos (sslength blksub) 2 0))<BR> );end while2<BR> (setq blkdxf (tblnext "BLOCK"))<BR> );END WHILE1
(endexcel)<BR> (setq *error* oer)<BR> (princ)<BR> ) 學習了，多謝分享！！ 什么书，很不错 书名是什么？？？？？？？？ 搞了半天，还是这个最实用易懂，最简洁！ 确实不错的说 学习了，多谢分享！！ 2005年就有了，但偶才看到，谢谢分享 过来学习，版主辛苦了！ 学习了，多谢分享！！ 很好我真好需要
页:
[1]
2