【Gu_xl】CAD表格系列之==== CAD普通线画表格转Excel表格
本帖最后由 牢固 于 2014-2-25 10:25 编辑程序需加载最新的XDRX_API使用！
主程序（更新 2014.02.25 ）：
;;CAD表格转Excel By Gu_xl 2013.07.01 更新 2014.02.25;;晓东API应用
(defun c:C2X(/ *xlapp* *error*
GETTXTHEIGHT GETTEXTSTR SS
FUZZ XL COL
YL ROW GRIDLST
TXTSS MINTXTH TMP
GRIDSCALE PX2WSCALE PX2HSCALE
CADCOLWIDTHS CADCOLWIDTH CADTOTALWIDTH
CADROWHEIGHTS CADROWHEIGHTCADTOTALHEIGHT
RANGE HEIGHT ROWHEIGHT
HEIGHTSCALE WIDESCALE TXTHSCALE
HSCALE STANDARDFONTSIZE
DEFAULTROWHEIGHT DEFAULTCOLWIDTH
I B TO
TXTSTR TXTH FONTbox tmp h2wscale
)
;;计算字高
(defun gettxtheight (e / h dxf s txt)
;(setq box (gxl-getTextBox e))
;(abs (- (car (cdaddr box)) (cadar box)))
(setq e (entget e)
h (cdr (assoc 40 e))
dxf (cdr (assoc 0 e))
)
(cond
((= "TEXT" dxf) h)
((= "MTEXT" dxf)
(setq txt (cdr (assoc 1 e)))
(setq s (gxl-RegExSearch txt "\\\\H.+?x" "im"))
(if s
(* h (atof (substr (caddar s) 3)))
h
)
)
)
)
;;获取文字
(defun Gettextstr (ent / regex s)
(setq ent (entget ent))
(setq s (cdr (assoc 1 ent)))
(if (= "TEXT" (cdr (assoc 0 ent)))
s
(progn
(setq regex (vlax-create-object "Vbscript.RegExp")) ;引用正则表达式控件
(if regex
(progn
(vlax-put-property regex "IgnoreCase" 0) ;不忽略大小写
(vlax-put-property regex "Global" 1) ;匹配方式，全文字匹配
;替换\\字符
(vlax-put-property regex "Pattern" "\\\\\\\\")
(setq s (vlax-invoke-method regex "Replace" s (chr 1)))
;替换\{字符
(vlax-put-property regex "Pattern" "\\\\{")
(setq s (vlax-invoke-method regex "Replace" s (chr 2)))
;替换\}字符
(vlax-put-property regex "Pattern" "\\\\}")
(setq s (vlax-invoke-method regex "Replace" s (chr 3)))
;删除段落缩进格式
(vlax-put-property regex "Pattern" "\\\\pi(.[^;]*);")
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除制表符格式
(vlax-put-property regex "Pattern" "\\\\pt(.[^;]*);")
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除堆迭格式
(vlax-put-property
regex
"Pattern"
"\\\\S(.[^;]*)(\\^|#|\\\\)(.[^;]*);"
)
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除字体、颜色、字高、字距、倾斜、字宽、对齐格式
(vlax-put-property
regex
"Pattern"
"(\\\\F|\\\\f|\\\\C|\\\\H|\\\\\T|\\\\Q|\\\\W|\\\\A)(.[^;]*);"
)
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除下划线、删除线格式
(vlax-put-property
regex
"Pattern"
"(\\\\L|\\\\O|\\\\l|\\\\o)"
)
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除不间断空格格式
(vlax-put-property regex "Pattern" "\\\\~")
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除换行符格式
(vlax-put-property regex "Pattern" "\\\\P")
(setq s (vlax-invoke-method regex "Replace" s "\r\n"))
;删除{}
(vlax-put-property regex "Pattern" "({|})")
(setq s (vlax-invoke-method regex "Replace" s ""))
;替换回\\,\{,\}字符
(vlax-put-property regex "Pattern" "\\x01")
(setq s (vlax-invoke-method regex "Replace" s "\\"))
(vlax-put-property regex "Pattern" "\\x02")
(setq s (vlax-invoke-method regex "Replace" s "{"))
(vlax-put-property regex "Pattern" "\\x03")
(setq s (vlax-invoke-method regex "Replace" s "}"))
(vlax-release-object regex)
)
)
s
)
)
)
;;主程序开始
(defun *error* (s)
(princ s)
(princ "\n***创建表格失败，请检查表格是否全部为封闭单元格***")
(if (= 5 (getvar "undoctl"))
(command "undo" "b")
)
(gxl-Sys-ReBackViewSize)
(xdrx_statusbar_end)
(if *xlapp*
(progn
(vla-put-visible *xlapp* 1)
(vlxls-app-quit *xlapp* nil)
)
)
(princ)
)
(XDRX_BEGIN (list "cmdecho" 0 "expert" 5 "qaflags" 0))
(setq ss (ssget '((0 . "*polyline,line"))))
(setq fuzz 0.01)
(if ss
(progn
(gxl-SYS-STORESVIEWSIZE)
(command "_undo" "_m")
;;拓扑表格
(setq ss (GetTableLst ss fuzz))
(command "undo" "b")
(setq xl (cadr ss) ;_ 列数的X坐标，从小到大
col (caddr ss) ;_ 列数
yl (cadddr ss) ;_ 列数的y坐标,从大到小
row (car (cddddr ss)) ;_ 行数
CadColWidths (nth 5 ss) ;_ 各列CAD宽度
CadRowHeights (nth 6 ss) ;_ 各行CAD高度
;box (last ss)
GridLst (car ss)
)
(setq h2wscale 0.134871794871795)
(setq *xlapp* (vlxls-app-new t))
;(setq r (vlax-get-property *xlapp* 'range "A1"))(VL-CATCH-ALL-APPLY 'VLXLS-geT-ROWHEIGHT (list *xlapp* 1))
(setq CadcolWidth (apply 'min CadColWidths) ;_ CAD最小宽度
CadTotalWidth (apply '+ CadColWidths) ;_ CAD总宽度
CadrowHeight (apply 'min CadRowHeights) ;_ CAD最小高度
CadTotalHeight (apply '+ CadRowHeights) ;_ CAD总高度
range (vlax-get-property *xlapp* 'range "a1")
Height 19.50 ;_ Excel像素行高，实际行高15
txthscale (/ Height CadrowHeight)
)
(setq StandardFontSize (vlax-get-property *XLAPP* 'StandardFontSize))
;(setq defaultHeight (/ *THeight* StandardFontSize)) ;_ 默认高度
(setq defaultrowheight (VLXLS-GET-PROPERTY *XLAPP* "activesheet.rows.RowHeight"))
(setq defaultColWidth (VLXLS-GET-PROPERTY *XLAPP* "activesheet.Columns.ColumnWidth"))
(setq i 1)
(foreach a CadColWidths
;(setq b (* a widescale hscale 1.197143))
(setq b (* h2wscale Height (/ a CadrowHeight)))
(VL-CATCH-ALL-APPLY 'vlxls-Put-ColumnWidth (list *xlapp* i b))
(setq i (1+ i))
)
(setq i 1)
(foreach a CadRowHeights
;(setq b (* a heightscale hscale))
(setq b (* Height (/ a CadrowHeight)))
(VL-CATCH-ALL-APPLY 'VLXLS-PUT-ROWHEIGHT (list *xlapp* i b))
(setq i (1+ i))
)
(xdrx_statusbar_begin "Excel表" (setq to (length Gridlst)))
(setq pbar 0)
(foreach a Gridlst
(xdrx_statusbar_setpos (setq pbar (1+ pbar)))
(if (apply '/= (gxl-STRPARSE (car a) ":"))
(vlxls-cell-merge *xlapp* (car a))
)
(setq range (vlax-get-property *xlapp* "range" (car a)))
;(command "_zoom" (trans (caadr a) 0 1) (trans (cadadr a) 0 1) "_zoom" "0.95x")
(XDRX_DOCUMENT_ASSUREINCURRENTVIEW (apply 'mapcar (cons 'min (cadr a))) (apply 'mapcar (cons 'max (cadr a))))
;(setq txtss (ssget "_c" (trans (caadr a) 0 1) (trans (cadadr a) 0 1) '((0 . "*text"))))
(setq txtss (ssget "_cp" (mapcar '(lambda (x) (trans x 0 1)) (cadr a))'((0 . "*text"))))
(if txtss
(progn
(setq txtstr "")
(setq txtss
(vl-sort
(gxl-SEL-SS->LIST txtss)
'(lambda (a b)
(> (cadr (gxl-dxf a 10)) (cadr (gxl-dxf b 10)))
)
)
)
(setq txtss (vl-remove-if-not '(lambda (x / box) (gxl-inorout (cadr a) (gxl-MIDPOINT (car (setq box (xdrx_entity_box x))) (caddr box)))) txtss))
(if txtss
(progn
(setq txtstr (Gettextstr (car txtss))
txth (gettxtheight (car txtss))
txtss (cdr txtss)
)
(while txtss
(setq txtstr (strcat txtstr "\r\n" (Gettextstr (car txtss)))
txth (max txth (gettxtheight (car txtss)))
txtss (cdr txtss)
)
)
(vlxls-cell-put-value *xlapp* (car a) txtstr)
(vlax-put-property
(setq font (vlax-get-property
range
"font"
)
)
"Size"
(* txthtxthscale )
)
)
)
)
)
(vlax-put-property range "HorizontalAlignment" -4108)
(vlax-put-property range "VerticalAlignment" -4108)
(vlxls-cell-border *xlapp* (car a) t)
)
(xdrx_statusbar_end)
(gxl-SYS-RESTORESVIEWSIZE)
(vla-put-visible *xlapp* 1)
(vlax-release-object *XLAPP*)
;|(alert
(strcat
"********************************\n\n*"
" CAD表格到Excel表格转换完毕!*\n\n"
"*版权所有: Gu_xl *\n\n"
"*联系方式 : Gu_xl@sohu.com *\n\n"
"********************************")
)|;
)
)
(XDRX_END)
(princ)
)
全部源码:
**** Hidden Message *****
编译的Fas文件：
初次制作，不知效果如何
第一次坐上G版的沙发。 no function definition: XDRX_DOCUMENT_UCSOFF
***创建表格失败，请检查表格是否全部为封闭单元格***
也用不了，表格线肯定是封闭的
看来只有等老大更新XDRX_API了:) xdrx_ucsoff原来是这个名称 sjj 发表于 2013-7-7 10:41
no function definition: XDRX_DOCUMENT_UCSOFF
***创建表格失败，请检查表格是否全部为封闭单元格***
也 ...
你用的是哪个版本的ACAD？
XDSoft 发表于 2013-7-7 12:51
你用的是哪个版本的ACAD？
2004 2006二个版本
都有这个问题
sjj 发表于 2013-7-7 15:23
2004 2006二个版本
都有这个问题
最新XDRX_API 0707版发布了，去下载测试下吧。
测试成功
速度好像有点慢 sjj 发表于 2013-7-7 15:54
测试成功
速度好像有点慢
贴个测试的动画来论坛吧。看看。多大的表格？
sjj 发表于 2013-7-7 16:51
初次制作，不知效果如何
做的不错，效果，时间还好啊。
还有什么建议吗，说说，完善它。
本帖最后由 sjj 于 2013-7-7 17:41 编辑
电脑配置差了些
表格转换时间还可以了，
刚测试表格，离表格线近的文字会“串门”;P
（除本身位置，相邻的单元格内重复出现）
sjj 发表于 2013-7-7 17:40
电脑配置差了些
表格转换时间还可以了，
刚测试表格，离表格线近的文字会“串门”
串门时因为隔壁的文字压线串门了！
牢固 发表于 2013-7-7 19:31
串门时因为隔壁的文字压线串门了！
选文字的时候，可否用文字的中心点判断，中心在哪个格子就是哪个格子，感觉这样误差能小些，如果中心都在线附近了，那文字就串的太厉害了，一般的表格不会出现这样的。
newer 发表于 2013-7-7 20:51
选文字的时候，可否用文字的中心点判断，中心在哪个格子就是哪个格子，感觉这样误差能小些，如果中心都在 ...
不错的建议！一楼程序已按此法修改！