[原创]：CAD中多个不同的属性快的属性写入EXCEL表中的不同表单中的程序！

whitephoto

我正在学visp,希望能多多观摩，希望谁能给我寄一份，我的E-mal:whitephoto@sina.com.多谢！

ynj

黄版主能否把程序改成从ACCESS里读数据？

秦林

我不能下载，能发E——mail:Qinlin71@sohu.com

LUCAS

最初由 黄卫文 发布
[B]
CAD如果在运行时是没有办法清除的，如果你想尽快清出EXCEL占用的内存空间，你可以退出运行的CAD程序?.. [/B]

;;把所有的參考excel的物件都RELEASE,就可以放了EXCEL

citykunan

将块的一些信息提取到EXCEL的例子，拿来与诸位分享。：）

2. 
   
3. (defun c:blk2xls (/ apl-exit initexcel endexcel datacell dorow dotable appxls
   
4.       xlsworkbooks newbook newsheet newitem xlscells objs count
   
5.       ent claves numrow title blkss blksub blk_qty k0 i0 blkname
   
6.       xscale yscale zscale rotang
   
7.       blkdxf numcol insert0)
   
8.   ;;;1.定义离开函数
   
9.    (defun apl-exit (msg)
   
10.      (endexcel)
    
11.      (prompt msg)
    
12.      (setq *error* oer)
    
13.    )
    
14.   ;;;2.initexcel用来初始M Excel
    
15.   (defun initexcel ()
    
16.     (setq appxls (vlax-get-or-create-object "excel.application")
    
17.    xlsworkbooks (vlax-get-property appxls "workbooks")
    
18.    newbook (vlax-invoke-method xlsworkbooks "add")
    
19.    newsheet (vlax-get-property newbook "sheets")
    
20.    newitem (vlax-get-property newsheet "item" 1)
    
21.    xlscells (vlax-get-property newitem "cells")
    
22.     )
    
23.     (vla-put-visible appxls :vlax-true)
    
24.   )
    
25.   ;;;3.endexcel用来释放excel
    
26.   (defun endexcel ()
    
27.     (vlax-release-object xlscells)
    
28.     (vlax-release-object newitem)
    
29.     (vlax-release-object newsheet)
    
30.     (vlax-release-object newbook)
    
31.     (vlax-release-object xlsworkbooks)
    
32.     (vlax-release-object appxls)
    
33.   )
    
34.   ;;;4.datacell将value填入numrow,col的格子中
    
35.   (defun datacell (nurow col value)
    
36.     (vlax-put-property xlscells "item" numrow col (vl-princ-to-string value))
    
37.   )
    
38.   (setq oer *error*
    
39. *error* apl-exit
    
40.   )
    
41.   (vl-load-com)
    
42.   (initexcel)
    
43.   (setq numrow 1 numcol 0)
    
44.   ;;;5.列出表头
    
45.   (datacell numrow (setq numcol (1+ numcol)) "Bock name")
    
46.   (datacell numrow (setq numcol (1+ numcol)) "X scale")
    
47.   (datacell numrow (setq numcol (1+ numcol)) "Y scale")
    
48.   (datacell numrow (setq numcol (1+ numcol)) "Z scale")
    
49.   (datacell numrow (setq numcol (1+ numcol)) "Angle")
    
50.   (datacell numrow (setq numcol (1+ numcol)) "Number")
    
51.   ;;;6.依次处理各图块的参考
    
52.   (setq blkdxf (tblnext "BLOCK" t))
    
53.   (while blkdxf ;while1
    
54.      (setq blkname (cdr (assoc 2 blkdxf))
    
55.     blkss (ssget "x" (list (cons 0 "INSERT") (cons 2 blkname)))
    
56.      )
    
57.      (setq i0 0)
    
58.      (if blkss
    
59.         (setq blkss_qty (sslength blkss)) ;写出块的数量
    
60.         (setq blkss_qty 0);图面上没有这个块则数量为0
    
61.      )
    
62.      (while (< i0 blkss_qty) ;while2 ;当有这个图块时;;;7.依条件建立图块参考的选集
    
63.        (setq insert0 (ssname blkss i0)
    
64.              xscale (cdr (assoc 41 (entget insert0)))
    
65.       yscale (cdr (assoc 42 (entget insert0)))
    
66.       zscale (cdr (assoc 43 (entget insert0)))
    
67.       rotang (cdr (assoc 50 (entget insert0)))
    
68.       blksub (ssget "x" (list (cons 0 "INSERT")
    
69.          (cons 2 blkname)
    
70.          (cons 41 xscale)
    
71.          (cons 42 yscale)
    
72.          (cons 43 zscale)
    
73.          (cons 50 rotang)))
    
74.       blkss_qty (- blkss_qty (sslength blksub))
    
75.       numrow (1+ numrow)
    
76.       numcol 0
    
77.       k0 0
    
78.         )
    
79.         (while (< k0 (sslength blksub)) ;while3
    
80.    (setq blkss (ssdel (ssname blksub k0) blkss))
    
81.    (setq k0 (1+ k0))
    
82. );end whlie3
    
83.        ;;;8.写入资料
    
84.        (datacell numrow (setq numcol (1+ numcol)) blkname)
    
85.        (datacell numrow (setq numcol (1+ numcol)) (rtos xscale))
    
86.        (datacell numrow (setq numcol (1+ numcol)) (rtos yscale))
    
87.        (datacell numrow (setq numcol (1+ numcol)) (rtos zscale))
    
88.        (datacell numrow (setq numcol (1+ numcol)) (rtos (* 180 (/ rotang pi))))
    
89.        (datacell numrow (setq numcol (1+ numcol)) (rtos (sslength blksub) 2 0))
    
90.       );end while2
    
91.       (setq blkdxf (tblnext "BLOCK"))
    
92.     );END WHILE1
    
93. 
    
94.    (endexcel)
    
95.    (setq *error* oer)
    
96.    (princ)
    
97. )
    

<br /> (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<br /> <br />    (endexcel)<br />    (setq *error* oer)<br />    (princ)<br /> )<br />

li809

还是不能下载,能发给我吗
baoshun01@163.com

cq_qg

很好的东西！可是我不能下载！与excellink有点相似！不知道能不能往回倒数据。

沙丁鱼

谢谢了，高手。我特别急需那个附件，能给俺发一个吗

shangri-la

这是个好东西
谢谢啦！

lingfengm

不能下载啊？
呵呵，谁能够再上传一次么

cdjtsf

谢谢20楼的，源码可以参考一下，vlx格式的看不了只能用

龙井茶

我是新手，还有些看不懂，继续努力吧！

chdragon

最初由 黄卫文 发布
[B]仅以此：祝晓东生日快乐！（本应该是昨天贴的。）
程序的功能：将CAD中带属性的不同名的块，将其属性值写入EXCEL表单中，表单的名称同所插入的块名相同，本程序为共享程序，如果每张表单中需要写的属性值小于300个?.. [/B]

楼主，连接失效了啊，下载不得哦，能不能给我发一份，yg972@21cn.com，谢谢

beyond_he

这个东西很好

kimu

怎么才能让下载呀