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

whitephoto · 发表于 2003-4-13 16:52:05

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

ynj · 发表于 2004-11-23 09:04:19

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

秦林 · 发表于 2004-12-30 18:45:45

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

LUCAS · 发表于 2004-12-31 08:03:50

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

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

citykunan · 发表于 2005-2-16 13:38:16

将块的一些信息提取到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)
)

(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) 
 )

li809 · 发表于 2005-2-16 20:21:23

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

cq_qg · 发表于 2005-2-25 14:49:06

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

沙丁鱼 · 发表于 2005-4-5 10:43:33

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

shangri-la · 发表于 2005-9-14 09:01:43

这是个好东西
谢谢啦！

lingfengm · 发表于 2006-2-21 15:47:47

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

cdjtsf · 发表于 2006-2-22 08:01:46

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

龙井茶 · 发表于 2006-3-7 22:47:40

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

chdragon · 发表于 2006-3-15 22:28:50

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

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

beyond_he · 发表于 2006-6-10 11:45:14

这个东西很好

kimu · 发表于 2006-7-26 09:03:35

怎么才能让下载呀

账号		自动登录	找回密码
密码			立即注册

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

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

怎么才能让下载呀