excel table Autoca普通文字表格互转

/db_自贡黄明儒_ · 发表于 2017-10-16 10:34:09

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有帐号？立即注册

x

本帖最后由 /db_自贡黄明儒_ 于 2017-10-20 09:16 编辑

众所周知，excel具有强大易用的统计功能，现在高版本的cad的table也起来起象excel了。excel table Autoca普通文字表格，三者互转就很有用。
许多人对此都有研究，如G版。
下面是我收集的
truetable是破解版，供学习研究用，为尊重作者劳动成果，希望用后删除。不过你可以使用下面8楼我用lisp编写的，没有版本限制，不过照样收费

/db_自贡黄明儒_ · 发表于 2017-10-16 10:37:23

本帖最后由 /db_自贡黄明儒_ 于 2017-10-18 13:24 编辑

此外，我还收集了其它版本

/db_自贡黄明儒_ · 发表于 2017-10-16 10:39:15

本帖最后由 /db_自贡黄明儒_ 于 2017-10-18 13:29 编辑

我还收集了其它版本

/db_自贡黄明儒_ · 发表于 2017-10-16 11:11:57

本帖最后由 /db_自贡黄明儒_ 于 2017-10-18 13:30 编辑

接楼上

/db_自贡黄明儒_ · 发表于 2017-10-16 11:14:33

也有lisp版本的，

;;; 提取cad表格到excel中的程序，功能比较简单，效率比较低
;;; by qjchen@gmail.com
;;; 练练手而已，功能比较弱，建议大家用truetable：）
;;; 要求r2000以上，要求所有的文本在格子中，每个格子只有一个文本，文本可在格
;;; 子内任何位置，要求非常规则的表格，表格从上到下的列数都一致
;;; 所以选择的时候最好不要选择标题栏
(defun c:qjchenb2e ( / column finallist i j outlist p1 p3 palist palllist phlist pvlist row rowlist ss x)
(setvar "osmode" 33)
(setq p1 (getpoint "\n左上角点：")
p3 (getpoint "\n右下角点：")
pvlist (vl-Get-Int-Pt (polar p1 0 1) (polar (list (car p1) (car (cdr p3)) 0) 0 1))
pvlist (mapcar '(lambda (x) (polar x pi 1)) pvlist)
phlist (vl-Get-Int-Pt (polar p1 (* pi 1.5) 1) (polar (list (car p3) (car (cdr p1)) 0) pi 1))
palllist (list pvlist)
i 1)
(repeat (- (length phlist) 1)
(setq palllist (append palllist (list (mapcar '(lambda (x)(list (car (nth i phlist)) (car (cdr x))(car (cddr x)))) pvlist)))
i (1+ i))
)
(setq column (length palllist) row (length (nth 0 palllist)) j 0 finallist nil)
(setvar "osmode" 0)
(repeat (- row 1)
(setq i 0 rowlist nil)
(repeat (- column 1)
(setq palist (list (nth j (nth i palllist))
(nth (1+ j) (nth i palllist))
(nth (1+ j) (nth (1+ i) palllist))
(nth j (nth (1+ i) palllist))))
(SETQ SS (SSGET "WP" palist))
(if (/= ss nil)
(setq rowlist (append rowlist (list (cdr (assoc 1 (ENTGET (SSNAME SS 0)))))))
(setq rowlist (append rowlist (list " ")))
)
(setq i (1+ i))
)
(setq finallist (append finallist (list rowlist)) j (1+ j))
)
(setq outlist finallist)
(2xl outlist)
)
;;; 引用一个韩国朋友写的关于两点和多个物体交点的程序
(defun vl-Get-Int-Pt (FirstPoint SecondPoint / acadDocument mSpace SSetName
SSets SSet reapp ex obj Baseline
)
(vl-load-com)
(setq acadDocument (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq mSpace (vla-get-ModelSpace acadDocument))
(setq SSetName "MySSet")
(setq SSets (vla-get-SelectionSets acadDocument))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list SSets SSetName )))
(vla-clear (vla-Item SSets SSetName))
)
(setq SSet (vla-Item SSets SSetName))
(setq Baseline (vla-Addline mspace (vlax-3d-point FirstPoint)(vlax-3d-point SecondPoint)))
(vla-SelectByPolygon SSet acSelectionSetFence
(kht:list->safearray (append FirstPoint SecondPoint) 'vlax-vbdouble))
(vlax-for obj sset (if (setq ex (kht-intersect (vlax-vla-object->ename BaseLine)(vlax-vla-object->ename obj)))
(setq reapp (append reapp ex))
)
)
(vla-delete BaseLine)
(setq reapp (vl-sort reapp '(lambda (e1 e2) (< (car e1) (car e2)))))
reapp
)
;;; 修改了一点，让text和其他的没有交点
(defun kht-intersect (en1 en2 / a b x ex ex-app c d e)
(vl-load-com)
(setq c (cdr (assoc 0 (entget en1)))
d (cdr (assoc 0 (entget en2)))
)
(if (or (= c "TEXT") (= d "TEXT") )
(setq e -1)
)
(setq En1 (vlax-ename->vla-object En1))
(setq En2 (vlax-ename->vla-object En2))
(setq a (vla-intersectwith en1 en2 acExtendNone))
(setq a (vlax-variant-value a))
(setq b (vlax-safearray-get-u-bound a 1))
(if (= e -1) (setq b e) )
(if (/= b -1)
(progn
(setq a (vlax-safearray->list a))
(repeat (/ (length a) 3)
(setq ex-app (append ex-app (list (list (car a) (cadr a) (caddr a))))
a (cdr (cdr (cdr a))))
)
ex-app
)
nil
)
)
(defun kht:list->safearray (lst datatype)
(vlax-safearray-fill (vlax-make-safearray (eval datatype) (cons 0 (1- (length lst)))) lst)
)
(defun TerminaExcel ()
(vlax-release-object *cells*)
(vlax-release-object *item*)
(vlax-release-object *workbooks*)
(vlax-release-object *Excel*)
)
(defun IniciaExcel (/ m)
(vl-load-com)
(setq m (vlax-get-or-create-object "excel.application"))
(if (= (vla-get-visible m) :Vlax-false)
(vla-put-visible (vlax-get-or-create-object "excel.application") T)
)
(setq *Excel* (vlax-get-or-create-object "excel.application"))
(if (= (vlax-get-property *Excel* "activeworkbook") nil)
(progn
(setq *workbooks* (vlax-get-property *Excel* "workbooks"))
(vlax-invoke-method *workbooks* "add")
(setq deltaRow nil)
)
)
(setq *workbooks* (vlax-get-property *Excel* "activeworkbook")
*item* (vlax-get-property *workbooks* "activesheet"); *item* (vlax-get-property *sheets* "item" 1)
*cells* (vlax-get-property *item* "cells")
)
(if (= (vlax-get-object "Excel.Application") nil)
(progn
(vla-put-visible *Excel* T)
)
)
)
(defun 2xl (outlist / temp val cll rll cel ccel ccell curid curval curcell)
(IniciaExcel)
(setq list1 (conexcelcolumn) curRow 1)
(if (= deltaRow nil) (setq deltaRow 0))
(repeat (length outList)
(setq temp 1)
(repeat (length (nth 0 outlist))
(setq val (nth (1- temp) (nth (- curRow 1) outList)))
(setq cll (nth temp list1))
(setq rll (itoa (+ curRow deltaRow)))
(setq cel (strcat cll rll))
(setq curId (strcat (nth temp list1) (itoa (+ curRow deltaRow)))
curCell (vlax-variant-value (vlax-invoke-method *item* "Evaluate" curId))
curVal (nth (1- temp) (nth (- curRow 1) outList))
)
(vlax-put-property curCell "Formula" curVal)
(vlax-release-object curCell)
(setq temp (1+ temp))
)
(setq curRow (1+ curRow))
)
(setq deltaRow (+ deltaRow (- curRow 0)))
(TerminaExcel)
(princ)
)
;;;产生一个和excel的列对应的表格
(defun conexcelcolumn (/ a b list1)
(setq a 65 list1 nil)
(repeat 26
(setq list1 (append list1 (list (chr a))) a (1+ a))
)
(setq a 65)
(repeat 26
(setq b 65)
(repeat 26
(setq list1 (append list1 (list (strcat (chr a) (chr b)))))
(setq b (1+ b))
)
(setq a (1+ a))
)
list1
)
(princ "\n By qjchen@gmail.com, The command is qjchenb2e")
(princ)

;;; 提取cad表格到excel中的程序，功能比较简单，效率比较低 
;;; by <a href=\"mailto:qjchen@gmail.com\">qjchen@gmail.com</a> 
;;; 练练手而已，功能比较弱，建议大家用truetable：） 
;;; 要求r2000以上，要求所有的文本在格子中，每个格子只有一个文本，文本可在格 
;;; 子内任何位置，要求非常规则的表格，表格从上到下的列数都一致 
;;; 所以选择的时候最好不要选择标题栏 
 
 
 
 
(defun c:qjchenb2e ( / column finallist i j outlist p1 p3 palist palllist phlist pvlist row rowlist ss x) 
  (setvar "osmode" 33) 
  (setq p1 (getpoint "\n左上角点：") 
        p3 (getpoint "\n右下角点：") 
pvlist (vl-Get-Int-Pt (polar p1 0 1) (polar (list (car p1) (car (cdr p3)) 0) 0 1)) 
pvlist (mapcar '(lambda (x) (polar x pi 1)) pvlist) 
        phlist (vl-Get-Int-Pt (polar p1 (* pi 1.5) 1) (polar (list (car p3) (car (cdr p1)) 0) pi 1)) 
        palllist (list pvlist) 
        i 1) 
  (repeat (- (length phlist) 1) 
    (setq palllist (append palllist (list (mapcar '(lambda (x)(list (car (nth i phlist)) (car (cdr x))(car (cddr x)))) pvlist))) 
          i (1+ i)) 
  ) 
  (setq column (length palllist) row (length (nth 0 palllist)) j 0 finallist nil) 
  (setvar "osmode" 0) 
  (repeat (- row 1) 
    (setq i 0 rowlist nil) 
    (repeat (- column 1) 
      (setq palist (list (nth j (nth i palllist)) 
      (nth (1+ j) (nth i palllist)) 
      (nth (1+ j) (nth (1+ i) palllist)) 
      (nth j (nth (1+ i) palllist)))) 
     (SETQ SS (SSGET "WP" palist)) 
      (if (/= ss nil) 
 (setq rowlist (append rowlist (list (cdr (assoc 1 (ENTGET (SSNAME SS 0))))))) 
          (setq rowlist (append rowlist (list " "))) 
      ) 
      (setq i (1+ i)) 
    ) 
    (setq finallist (append finallist (list rowlist)) j (1+ j)) 
  )       
  (setq outlist finallist) 
         
  (2xl outlist) 
) 
 
 
 
 
;;; 引用一个韩国朋友写的关于两点和多个物体交点的程序 
(defun vl-Get-Int-Pt (FirstPoint SecondPoint / acadDocument mSpace SSetName 
SSets SSet reapp ex obj Baseline 
    ) 
  (vl-load-com) 
  (setq acadDocument (vla-get-ActiveDocument (vlax-get-acad-object))) 
  (setq mSpace (vla-get-ModelSpace acadDocument)) 
  (setq SSetName "MySSet") 
  (setq SSets (vla-get-SelectionSets acadDocument)) 
  (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list SSets SSetName ))) 
    (vla-clear (vla-Item SSets SSetName)) 
  ) 
  (setq SSet (vla-Item SSets SSetName)) 
  (setq Baseline (vla-Addline mspace (vlax-3d-point FirstPoint)(vlax-3d-point SecondPoint))) 
  (vla-SelectByPolygon SSet acSelectionSetFence 
      (kht:list->safearray (append FirstPoint SecondPoint) 'vlax-vbdouble)) 
  (vlax-for obj sset (if (setq ex (kht-intersect (vlax-vla-object->ename BaseLine)(vlax-vla-object->ename obj))) 
      (setq reapp (append reapp ex)) 
    ) 
  ) 
  (vla-delete BaseLine) 
  (setq reapp (vl-sort reapp '(lambda (e1 e2) (< (car e1) (car e2))))) 
  reapp 
) 
 
 
 
 
;;; 修改了一点，让text和其他的没有交点 
(defun kht-intersect (en1 en2 / a b x ex ex-app c d e) 
  (vl-load-com) 
  (setq c (cdr (assoc 0 (entget en1))) 
d (cdr (assoc 0 (entget en2))) 
  ) 
  (if (or (= c "TEXT") (= d "TEXT") ) 
    (setq e -1) 
  ) 
  (setq En1 (vlax-ename->vla-object En1)) 
  (setq En2 (vlax-ename->vla-object En2)) 
  (setq a (vla-intersectwith en1 en2 acExtendNone)) 
  (setq a (vlax-variant-value a)) 
  (setq b (vlax-safearray-get-u-bound a 1)) 
  (if (= e -1) (setq b e) ) 
  (if (/= b -1) 
    (progn 
      (setq a (vlax-safearray->list a)) 
      (repeat (/ (length a) 3) 
(setq ex-app (append ex-app (list (list (car a) (cadr a) (caddr a)))) 
     a (cdr (cdr (cdr a)))) 
      ) 
      ex-app 
    ) 
    nil 
  ) 
) 
 
 
(defun kht:list->safearray (lst datatype) 
  (vlax-safearray-fill (vlax-make-safearray (eval datatype) (cons 0 (1- (length lst)))) lst) 
) 
 
 
(defun TerminaExcel () 
  (vlax-release-object *cells*) 
  (vlax-release-object *item*) 
  (vlax-release-object *workbooks*) 
  (vlax-release-object *Excel*) 
) 
 
 
 
 
(defun IniciaExcel (/ m) 
  (vl-load-com) 
  (setq m (vlax-get-or-create-object "excel.application")) 
  (if (= (vla-get-visible m) :Vlax-false) 
    (vla-put-visible (vlax-get-or-create-object "excel.application") T) 
  ) 
  (setq *Excel* (vlax-get-or-create-object "excel.application")) 
  (if (= (vlax-get-property *Excel* "activeworkbook") nil) 
    (progn 
      (setq *workbooks* (vlax-get-property *Excel* "workbooks")) 
      (vlax-invoke-method *workbooks* "add") 
      (setq deltaRow nil) 
    ) 
  ) 
  (setq *workbooks* (vlax-get-property *Excel* "activeworkbook") 
*item* (vlax-get-property *workbooks* "activesheet");        *item*           (vlax-get-property *sheets* "item" 1) 
*cells* (vlax-get-property *item* "cells") 
  ) 
  (if (= (vlax-get-object "Excel.Application") nil) 
    (progn 
      (vla-put-visible *Excel* T) 
    ) 
  ) 
) 
 
 
(defun 2xl (outlist / temp val cll rll cel ccel ccell curid curval curcell) 
 (IniciaExcel) 
 (setq list1 (conexcelcolumn) curRow 1) 
 (if (= deltaRow nil) (setq deltaRow 0)) 
 (repeat (length outList) 
    (setq temp 1) 
    (repeat (length (nth 0 outlist)) 
     (setq val (nth (1- temp) (nth (- curRow 1) outList))) 
     (setq cll (nth temp list1)) 
     (setq rll (itoa (+ curRow deltaRow))) 
(setq cel (strcat cll rll)) 
(setq curId (strcat (nth temp list1) (itoa (+ curRow deltaRow))) 
   curCell (vlax-variant-value (vlax-invoke-method *item* "Evaluate" curId)) 
   curVal (nth (1- temp) (nth (- curRow 1) outList)) 
      ) 
      (vlax-put-property curCell "Formula" curVal) 
      (vlax-release-object curCell) 
      (setq temp (1+ temp)) 
    ) 
    (setq curRow (1+ curRow)) 
 ) 
 (setq deltaRow  (+ deltaRow (- curRow 0))) 
 (TerminaExcel) 
 (princ) 
) 
 
 
;;;产生一个和excel的列对应的表格 
(defun conexcelcolumn (/ a b list1) 
  (setq a 65 list1 nil) 
  (repeat 26 
    (setq list1 (append list1 (list (chr a))) a (1+ a)) 
  ) 
  (setq a 65) 
  (repeat 26 
    (setq b 65) 
    (repeat 26 
      (setq list1 (append list1 (list (strcat (chr a) (chr b))))) 
      (setq b (1+ b)) 
    ) 
    (setq a (1+ a)) 
  ) 
  list1 
) 
 
 
(princ "\n By <a href=\"mailto:qjchen@gmail.com\">qjchen@gmail.com</a>, The command is qjchenb2e") 
(princ)

/db_自贡黄明儒_ · 发表于 2017-10-16 11:17:16

;;;;;;主程序
(defun c:cadtoexcel (/ ANG ASH DEFAULT DXF DXF10 DXF11 E FLAG FUZZ I LENCOLUMN LENROW LST LST3 LSTP1 LSTP2 LSTP3 LSTP4 MSXL-XL24HOURCLOCK N NUMROW OBJ OLDLST1 P1 P2 PLST RANGE RET SS TXTLST X XLAPP XLCONTINUOUS)
;;;;选择集转表
(defun ss2lst (ss / i e lst)
(setq i -1)
(repeat (sslength ss)
(setq e (ssname ss (setq i (1+ i)))
lst (cons e lst)
)
)
)
;;;;;删除重复元素
(defun deldump (lst / ret)
(vl-remove-if
(function (lambda (x)
(IF (NOT (MEMBER x RET))
(SETQ RET (CONS x RET))
nil
)
)
)
lst
)
ret
)
;;;;;取精度
(defun fixnum (bl)
(setq bl (/ (fix (* bl (expt 10.0 3))) (expt 10.0 3)))
)
;;;;根据X、Y坐标（各为一个表）求点表
(defun getplst (lst1 lst2 /)
(if flag
(setq oldlst1 lst1)
)
(repeat (1- (length lst2))
(if (and (cadr lst1) (cadr lst2))
(progn
(setq flag nil)
(setq lst (append (list (list (list (car lst1) (car lst2))
(list (car lst1) (cadr lst2))
(list (cadr lst1) (cadr lst2))
(list (cadr lst1) (car lst2))
)
)
lst
)
)
(setq lst1 (cdr lst1))
(if (and (cadr lst1) (cadr lst2))
(getplst lst1 lst2)
)
;;;递归
)
)
(setq lst2 (cdr lst2))
(if (cadr lst2)
(setq lst1 oldlst1)
(setq oldlst1 nil)
)
)
)
;;;excel输出函数,来源MJTD（局部有修改）
;;; 加载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
)
;;;打开带有新的工作簿的 Excel
(defun DSX-Open-Excel-New (dmode / appsession)
(princ "\n创建一个新的 Excel 电子表格文件...")
(cond ((setq appsession (vlax-create-object "Excel.Application"))
(vlax-invoke-method
(vlax-get-property appsession 'WorkBooks)
'Add
)
(if (= (strcase dmode) "SHOW")
(vla-put-visible appsession 1)
(vla-put-visible appsession 0)
)
)
)
appsession
)
;;; 获取行<relrow> 和列 <relcol>范围内的单个单元格对象
(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)
)
)
)
;;;将列表写到工作表指定行(startrow) 中的指定起始列(startcol)
(defun DSX-Excel-Put-RowList (lst startrow startcol)
(foreach itm lst
(msxl-put-value2
(DSX-Excel-Get-Cell range startrow startcol)
itm
)
(setq startcol (1+ startcol))
)
)
;;; 为指定单元格填入颜色
(defun DSX-Excel-Put-CellColor (row col intcol / rng)
(setq rng (DSX-Excel-Get-Cell (msxl-get-ActiveSheet xlapp) row col))
(msxl-put-colorindex (msxl-get-interior rng) intcol)
)
;;;为一行单元格填入颜色
(defun DSX-Excel-Put-RowCellsColor
(startrow startcol cols intcol / next)
(setq next startcol)
(repeat cols
(DSX-Excel-Put-CellColor startrow next intcol)
(setq next (1+ next))
)
)
;;;为选中的范围的实行自动调整宽度
(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
)
)
;;;退出并关闭Excel进程
(defun DSX-Excel-Quit (appsession)
(cond ((not (vlax-object-released-p appsession))
(vlax-release-object appsession)
)
)
)
;;;输出到excel
(defun tjwb
(lst / plst ss n txt lst1 lst2 m lst3 lst_bzmp i lst4 lst5)
(setq m 0)
(foreach x lst
(setq ss (ssget "wp" x '((0 . "*TEXT"))))
(if (not ss)
(setq ss (ssget "Cp" x '((0 . "*TEXT"))))
)
(SETQ N 0
txt ""
)
(if (and ss (< N (SSLENGTH SS)))
(progn
(WHILE (and ss (< N (SSLENGTH SS)))
(setq
txt (strcat (CDR (ASSOC 1 (ENTGET (SSNAME SS N)))) txt)
)
(SETQ LST1 (LIST txt))
(SETQ N (1+ N))
)
)
(progn
(setq txt "")
(SETQ LST1 (LIST txt))
)
)
(if (< m (1- lencolumn))
(progn
(SETQ lst2 (APPEND lst2 lst1))
)
(setq lst3 (APPEND lst3 (list lst2))
m 0
lst2 lst1
lst1 nil
)
)
(setq m (1+ m))
)
(setq lst3 (APPEND lst3 (list lst2)))
(DSX-Load-TypeLib-Excel)
(cond ((setq xlapp (DSX-Open-Excel-New "SHOW")
ash (msxl-Get-ActiveSheet xlapp)
range (msxl-Get-ActiveCell xlapp)
)
)
)
(setq numrow 1
i 0
)
(mapcar (function
(lambda (x)
(DSX-Excel-Put-RowList x numrow 1)
(DSX-Excel-Put-rowCellsColor 1 1 (length (car lst3)) 7)
(setq i (1+ i)
numrow (1+ numrow)
)
)
)
lst3
)
(DSX-Excel-RangeAutoFit ash)
(DSX-Excel-gridline ash)
(DSX-Excel-Quit ash)
)
(VL-LOAD-COM)
(setq p1 (getpoint "\n 请框选要导出EXCEL的表格")
p2 (getcorner p1 "\n 请框选要导出EXCEL的表格")
)
(setq ss (ssget "c" p1 p2 '((0 . "LINE")))
n -1
fuzz 1e-3
)
(repeat (sslength ss)
(setq e (ssname ss (setq n (1+ n)))
dxf (entget e)
dxf10 (cdr (assoc 10 dxf))
dxf11 (cdr (assoc 11 dxf))
ang (angle dxf10 dxf11)
)
(cond ((or (equal ang 0. fuzz) (equal ang pi fuzz))
(setq lstp1 (append lstp1 (list (list dxf10 dxf11))))
;;;(redraw e 3)
)
((equal (rem ang pi) 3.14159 fuzz)
(setq lstp1 (append lstp1 (list (list dxf11 dxf10))))
;;;(redraw e 4)
)
((or (equal ang (* pi 0.5) fuzz) (equal ang (* pi 1.5) fuzz))
(setq lstp2 (append lstp2 (list (list dxf10 dxf11))))
)
((equal (rem ang pi) 1.5708 fuzz)
(setq lstp2 (append lstp2 (list (list dxf11 dxf10))))
)
)
)
(setq lenrow (length (setq lstp3
(vl-sort
(deldump (mapcar '(lambda (x) (fixnum (cadar x))) lstp1)
)
'<
)
)
)
lencolumn (length (setq lstp4
(vl-sort
(deldump
(mapcar '(lambda (x) (fixnum (caar x))) lstp2)
)
'>
)
)
)
)
(setq flag t)
(getplst lstp4 lstp3)
(setq plst lst
lst nil
txtlst (tjwb plst)
)
(princ
"\nCAD线表格导出到EXCEL，仅支持直线。BY YJR111，命令cadtoexcel."
)
(princ)
)

;;;;;;主程序 
(defun c:cadtoexcel (/ ANG ASH DEFAULT DXF DXF10 DXF11 E FLAG FUZZ I LENCOLUMN LENROW LST LST3 LSTP1 LSTP2 LSTP3 LSTP4 MSXL-XL24HOURCLOCK N NUMROW OBJ OLDLST1 P1 P2 PLST RANGE RET SS TXTLST X XLAPP XLCONTINUOUS) 
;;;;选择集转表 
  (defun ss2lst        (ss / i e lst) 
    (setq i -1) 
    (repeat (sslength ss) 
      (setq e        (ssname ss (setq i (1+ i))) 
            lst        (cons e lst) 
      ) 
    ) 
  ) 
;;;;;删除重复元素 
  (defun deldump (lst / ret) 
    (vl-remove-if 
      (function        (lambda        (x) 
                  (IF (NOT (MEMBER x RET)) 
                    (SETQ RET (CONS x RET)) 
                    nil 
                  ) 
                ) 
      ) 
      lst 
    ) 
    ret 
  ) 
;;;;;取精度 
  (defun fixnum        (bl) 
    (setq bl (/ (fix (* bl (expt 10.0 3))) (expt 10.0 3))) 
  ) 
;;;;根据X、Y坐标（各为一个表）求点表 
  (defun getplst (lst1 lst2 /) 
    (if        flag 
      (setq oldlst1 lst1) 
    ) 
    (repeat (1- (length lst2)) 
      (if (and (cadr lst1) (cadr lst2)) 
        (progn 
          (setq flag nil) 
          (setq        lst (append (list (list        (list (car lst1) (car lst2)) 
                                        (list (car lst1) (cadr lst2)) 
                                        (list (cadr lst1) (cadr lst2)) 
                                        (list (cadr lst1) (car lst2)) 
                                  ) 
                            ) 
                            lst 
                    ) 
          ) 
          (setq lst1 (cdr lst1)) 
          (if (and (cadr lst1) (cadr lst2)) 
            (getplst lst1 lst2) 
          ) 
;;;递归 
        ) 
      ) 
      (setq lst2 (cdr lst2)) 
      (if (cadr lst2) 
        (setq lst1 oldlst1) 
        (setq oldlst1 nil) 
      ) 
    ) 
  ) 
;;;excel输出函数,来源MJTD（局部有修改） 
;;;  加载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 
  ) 
;;;打开带有新的工作簿的 Excel 
  (defun DSX-Open-Excel-New (dmode / appsession) 
    (princ "\n创建一个新的 Excel 电子表格文件...") 
    (cond ((setq appsession (vlax-create-object "Excel.Application")) 
           (vlax-invoke-method 
             (vlax-get-property appsession 'WorkBooks) 
             'Add 
           ) 
           (if (= (strcase dmode) "SHOW") 
             (vla-put-visible appsession 1) 
             (vla-put-visible appsession 0) 
           ) 
          ) 
    ) 
    appsession 
  ) 
;;; 获取行<relrow> 和列 <relcol>范围内的单个单元格对象 
  (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) 
      ) 
    ) 
  ) 
;;;将列表写到工作表指定行(startrow) 中的指定起始列(startcol) 
  (defun DSX-Excel-Put-RowList (lst startrow startcol) 
    (foreach itm lst 
      (msxl-put-value2 
        (DSX-Excel-Get-Cell range startrow startcol) 
        itm 
      ) 
      (setq startcol (1+ startcol)) 
    ) 
  ) 
;;; 为指定单元格填入颜色 
  (defun DSX-Excel-Put-CellColor (row col intcol / rng) 
    (setq rng (DSX-Excel-Get-Cell (msxl-get-ActiveSheet xlapp) row col)) 
    (msxl-put-colorindex (msxl-get-interior rng) intcol) 
  ) 
 
;;;为一行单元格填入颜色 
  (defun DSX-Excel-Put-RowCellsColor 
         (startrow startcol cols intcol / next) 
    (setq next startcol) 
    (repeat cols 
      (DSX-Excel-Put-CellColor startrow next intcol) 
      (setq next (1+ next)) 
    ) 
  ) 
;;;为选中的范围的实行自动调整宽度 
  (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 
    ) 
  ) 
;;;退出并关闭Excel进程 
  (defun DSX-Excel-Quit        (appsession) 
    (cond ((not (vlax-object-released-p appsession)) 
           (vlax-release-object appsession) 
          ) 
    ) 
  ) 
;;;输出到excel 
  (defun tjwb 
         (lst / plst ss n txt lst1 lst2 m lst3 lst_bzmp i lst4 lst5) 
    (setq m 0) 
    (foreach x lst 
      (setq ss (ssget "wp" x '((0 . "*TEXT")))) 
      (if (not ss) 
        (setq ss (ssget "Cp" x '((0 . "*TEXT")))) 
      ) 
      (SETQ N        0 
            txt        "" 
      ) 
      (if (and ss (< N (SSLENGTH SS))) 
        (progn 
          (WHILE (and ss (< N (SSLENGTH SS))) 
            (setq 
              txt (strcat (CDR (ASSOC 1 (ENTGET (SSNAME SS N)))) txt) 
            ) 
            (SETQ LST1 (LIST txt)) 
            (SETQ N (1+ N)) 
          ) 
        ) 
        (progn 
          (setq txt "") 
          (SETQ LST1 (LIST txt)) 
        ) 
      ) 
      (if (< m (1- lencolumn)) 
        (progn 
          (SETQ lst2 (APPEND lst2 lst1)) 
        ) 
        (setq lst3 (APPEND lst3 (list lst2)) 
              m           0 
              lst2 lst1 
              lst1 nil 
        ) 
      ) 
      (setq m (1+ m)) 
    ) 
    (setq lst3 (APPEND lst3 (list lst2))) 
    (DSX-Load-TypeLib-Excel) 
    (cond ((setq xlapp (DSX-Open-Excel-New "SHOW") 
                 ash   (msxl-Get-ActiveSheet xlapp) 
                 range (msxl-Get-ActiveCell xlapp) 
           ) 
          ) 
    ) 
    (setq numrow 1 
          i 0 
    ) 
    (mapcar (function 
              (lambda (x) 
                (DSX-Excel-Put-RowList x numrow 1) 
                (DSX-Excel-Put-rowCellsColor 1 1 (length (car lst3)) 7) 
                (setq i             (1+ i) 
                      numrow (1+ numrow) 
                ) 
              ) 
            ) 
            lst3 
    ) 
    (DSX-Excel-RangeAutoFit ash) 
    (DSX-Excel-gridline ash) 
    (DSX-Excel-Quit ash) 
  ) 
  (VL-LOAD-COM) 
  (setq        p1 (getpoint "\n 请框选要导出EXCEL的表格") 
        p2 (getcorner p1 "\n 请框选要导出EXCEL的表格") 
  ) 
  (setq        ss   (ssget "c" p1 p2 '((0 . "LINE"))) 
        n    -1 
        fuzz 1e-3 
  ) 
  (repeat (sslength ss) 
    (setq e        (ssname ss (setq n (1+ n))) 
          dxf        (entget e) 
          dxf10        (cdr (assoc 10 dxf)) 
          dxf11        (cdr (assoc 11 dxf)) 
          ang        (angle dxf10 dxf11) 
    ) 
    (cond ((or (equal ang 0. fuzz) (equal ang pi fuzz)) 
           (setq lstp1 (append lstp1 (list (list dxf10 dxf11)))) 
;;;(redraw e 3) 
          ) 
          ((equal (rem ang pi) 3.14159 fuzz) 
           (setq lstp1 (append lstp1 (list (list dxf11 dxf10)))) 
;;;(redraw e 4) 
          ) 
          ((or (equal ang (* pi 0.5) fuzz) (equal ang (* pi 1.5) fuzz)) 
           (setq lstp2 (append lstp2 (list (list dxf10 dxf11)))) 
          ) 
          ((equal (rem ang pi) 1.5708 fuzz) 
           (setq lstp2 (append lstp2 (list (list dxf11 dxf10)))) 
          ) 
    ) 
  ) 
 
  (setq        lenrow          (length (setq        lstp3 
                                 (vl-sort 
                                   (deldump (mapcar '(lambda (x) (fixnum (cadar x))) lstp1) 
                                   ) 
                                   '< 
                                 ) 
                          ) 
                  ) 
 
        lencolumn (length (setq        lstp4 
                                 (vl-sort 
                                   (deldump 
                                     (mapcar '(lambda (x) (fixnum (caar x))) lstp2) 
                                   ) 
                                   '> 
                                 ) 
                          ) 
                  ) 
  ) 
  (setq flag t) 
  (getplst lstp4 lstp3) 
  (setq        plst   lst 
        lst    nil 
        txtlst (tjwb plst) 
  ) 
  (princ 
    "\nCAD线表格导出到EXCEL，仅支持直线。BY YJR111，命令cadtoexcel." 
  ) 
  (princ) 
)

/db_自贡黄明儒_ · 发表于 2017-10-16 11:18:59

(defun c:c2e (/ hangdau)
(defun sosanh (e1 e2 / p1 p2)
(setq p1 (car e1)
p2 (car e2)
)
(if (equal (cadr p1) (cadr p2) fuzz)
(< (car p1) (car p2))
(< (cadr p2) (cadr p1))
)
)
(setq
ss (ssget '((0 . "TEXT")))
lst (ss2ent ss)
lst (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e)))))
lst
)
lst (mapcar '(lambda (e)
(if (= (cdr e) "*")
(cons (car e) "")
e
)
)
lst
)
caotext (cdr (assoc 40 (entget (ssname ss 0))))
fuzz (* caotext 1.0)
lst (vl-sort lst 'sosanh)
index 1
oldy nil
fn (getfiled "保存文件名" "" "csv" 1)
fid (open fn "w")
)
(foreach e lst
(if (equal oldy (cadr (car e)) fuzz)
(progn
(princ "," fid)
(setq index (1+ index))
)
(progn
(if hangdau
(progn
(setq index 1)
(princ "\n" fid)
)
(setq hangdau t)
)
)
)
(princ (cdr e) fid)
(setq oldy (cadr (car e)))
)
(close fid)
)
(defun ss2ent (ss / sodt index lstent)
(setq
sodt (if ss
(sslength ss)
0
)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)

(defun c:c2e (/ hangdau) 
  (defun sosanh        (e1 e2 / p1 p2) 
    (setq p1 (car e1) 
          p2 (car e2) 
    ) 
    (if        (equal (cadr p1) (cadr p2) fuzz) 
      (< (car p1) (car p2)) 
      (< (cadr p2) (cadr p1)) 
    ) 
  ) 
  (setq 
    ss            (ssget '((0 . "TEXT"))) 
    lst            (ss2ent ss) 
    lst            (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) 
                    lst 
            ) 
    lst            (mapcar '(lambda (e) 
                       (if (= (cdr e) "*") 
                         (cons (car e) "") 
                         e 
                       ) 
                     ) 
                    lst 
            ) 
    caotext (cdr (assoc 40 (entget (ssname ss 0)))) 
    fuzz    (* caotext 1.0) 
    lst            (vl-sort lst 'sosanh) 
    index   1 
    oldy    nil 
    fn            (getfiled "保存文件名" "" "csv" 1) 
    fid            (open fn "w") 
  ) 
  (foreach e lst 
    (if        (equal oldy (cadr (car e)) fuzz) 
      (progn 
        (princ "," fid) 
        (setq index (1+ index)) 
      ) 
      (progn 
        (if hangdau 
          (progn 
            (setq index 1) 
            (princ "\n" fid) 
          ) 
          (setq hangdau t) 
        ) 
      ) 
    ) 
    (princ (cdr e) fid) 
    (setq oldy (cadr (car e))) 
  ) 
  (close fid) 
) 
(defun ss2ent (ss / sodt index lstent) 
  (setq 
    sodt  (if ss 
            (sslength ss) 
            0 
          ) 
    index 0 
  ) 
  (repeat sodt 
    (setq ent         (ssname ss index) 
          index         (1+ index) 
          lstent (cons ent lstent) 
    ) 
  ) 
  (reverse lstent) 
)

/db_自贡黄明儒_ · 发表于 2017-10-16 11:20:51

本帖最后由 /db_自贡黄明儒_ 于 2017-10-18 13:35 编辑

综上所述，truetabe真不错，但有版本限制，而且还要付费。所以自己的还得自己编写，这样可以适用于各个版本

zhaoyafei19 · 发表于 2017-10-16 13:10:41

都不是最新版的啊

508000096 · 发表于 2017-10-16 19:16:14

/db_自贡黄明儒_ 发表于 2017-10-16 11:20

看起来功能还是比较齐全。

kqqt6236 · 发表于 2017-10-17 00:05:32

确实是好东西。

pengfei2010 · 发表于 2017-10-23 09:29:58

回帖是一种美德！感谢楼主的无私分享谢谢

sujia · 发表于 2017-10-25 09:53:54

你们都是前辈。
也在研究数据提取。
能否不打开cad就你能提取，比如用python爬虫在一堆dwg文件抓数据。

Throne · 发表于 2017-10-25 22:35:17

/db_自贡黄明儒_ 发表于 2017-10-16 11:11

乐游游戏安装程序包????

yaya-2016 · 发表于 2017-11-10 11:18:57

楼主：除了TRUETABLE哪个也是可以CAD-EXCEL互转的？

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

[表格] excel table Autoca普通文字表格互转

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

[表格] excel table Autoca普通文字表格 互转

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

[表格] excel table Autoca普通文字表格互转