我写的蹩脚的程序！
我写了个提取cad中的文字、坐标、图层、颜色的程序，太不理想了（非常蹩脚），有大哥能给改下改成用vla对象写的么？(defun c:Q2(/ ff ffn i ss ssdata ssn sstyp sx sy sz txt txtxy)(setvar "cmdecho" 0) ;;关闭变量
(setvar "blipmode" 0);;关闭控制点
(vl-load-com) ;;加载vlax扩展函数
;(setq ffn (getfiled "写出文件" "C:/Users/Administrator/Desktop/" "csv" 1));弹对话框提示设置保存路径及名称
(princ "\n选取文字:") ;提示选取文字
(setq ff (open "C://Users//Administrator//Desktop//文字.xls""w")) ;建立文本;W会把文本里面的内容清除
(setq i 0 ss '()) ;设置i初始值
(if (setq ss (ssget '((0 . "*TEXT")))) ;星号通配符，TEXT或者MTEXT都可以。
(repeat (sslength ss) ;对循环体中的表达式求SS图元个数值
(setq ssn (ssname ss i)) ;返回SS集中第i个图元名称
(setq ssdata (entget ssn)) ;返回图元的数据集
(setq txt (cdr (assoc 1 ssdata))) ;取文本数值
(setq txtxy (cdr (assoc 10 ssdata))) ;取文本坐标
(setq sx (rtos (nth 1 txtxy) 2 3)) ;将X坐标值实数转换成字符（目前没单独提取）
(setq sy (rtos (nth 0 txtxy) 2 3)) ;将y坐标值实数转换成字符（目前没单独提取）
(setq sz (rtos (nth 2 txtxy) 2 3)) ;将z坐标值实数转换成字符（目前没单独提取）
(setq tc (cdr (assoc 8 ssdata)))
(progn
(or
(setq col(cdr(assoc 62 ssdata)))
(setq col(cdr(assoc 62(tblsearch "layer" tc)))) ;随层颜色提取方式
)
col
)
(princ txt ff)
(princ "\t" ff);这个格式就是在同一行下一个内容
(princ txtxy ff)
(princ "\t" ff);这个格式就是在同一行下一个内容
(princ tc ff)
(princ "\t" ff);这个格式就是在同一行下一个内容
(princ col ff)
(princ "\t" ff);这个格式就是在同一行下一个内容
(princ sx ff)
(princ "\t" ff);这个格式就是在同一行下一个内容
(princ sy ff)
(princ "\t" ff);这个格式就是在同一行下一个内容
(princ sz ff)
(princ "\t" ff);这个格式就是在同一行下一个内容
(princ "\n" ff);这个格式就换行
;write-line不用换行,princ要用/n换行,princ要用/t下一列，（在同一行下一个内容）
(setq i (1+ i))
)
)
(close ff) ;关闭ff文件
;(princ (strcat "\n写出文件 " ffn)) ;提示提取文字完成
(princ) ;让提示行只显示一行
)CAD带文字的文件我就不传了，随便在CAD中新建几个文字提取试试就行。先谢谢大神了哈，我这是在研究CAD跟excel的转换问题，没整明白。
;;;;声明，下面的这些子函数我只是在原有基础修改，并非原创，请记住是这个人写的：落魄山人
(Defun Excel:WorkBooks-Add (ExcelApp FileName ishide / ExcelApp)
;;;示例(Excel:WorkBooks-Add ExcelApp "e:\\test.xlsx" t)
;(if (setq ExcelApp (vlax-get-or-create-object "Excel.Application"))
(progn
(setq newBooks(vlax-invoke
(vlax-get-property ExcelApp 'WorkBooks)
'Add
))
(if FileName (vlax-invoke newBooks "SaveAs" Filename));;;这里不能使用vlax-invoke-method
(if ishide
(vla-put-visible ExcelApp 1)
(vla-put-visible ExcelApp 0)
)
)
;)
newBooks
)
(Defun Excel:Range:Value-Put (ExcelApp index value / range)
(setq range (Excel:Range-Get ExcelApp SheetSpecify index))
(if (= 'list (type value))
(progn
(setq value$ (if (= 'list (type (car value))) (apply 'append value) value))
(vlax-for it range;;;对range对象，从左往右，再从上往下遍历，如"H10:I11"，先后顺序为H10 H11I10 I11
(PutP it 'value2 (car value$))
(setq value$ (cdr value$))
)
)
(progn
(vlax-for it range
(PutP it 'value2 value)
)
)
)
)
(defun Excel:Range-Get (ExcelApp SheetSpecify indexRange)
(vlax-get-property
(if SheetSpecify SheetSpecify(GetP ExcelApp "ActiveWorkbook.ActiveSheet"))
'range
(Excel:Index2A1 indexRange)
)
)
(defun Excel:Index2A1 (lst / num->col)
;;;(Excel:Index2A1 '(1 2 3 4))->"B1:D3" (Excel:Index2A1 '(1 2 ))->"B1"
;;说明:把数字转换为字母，转换规律为如1-26转换为字母A-Z，相当于十进制转换为27进制,不是26，隐藏了一个0
;;参数:n:数字，不限范围
;;返回:字符串，字母A-Z-ZZZZ......
(defun num->col (n) ;数字转为列，leemac
(if (< n 27)
(chr (+ 64 n))
(strcat
(num->col (/ (1- n) 26))
(num->col (1+ (rem (1- n) 26)))
)
)
)
(if (= 'list (type lst))
(cond
((= 2 (length lst))
(strcat (num->col (cadr lst)) (itoa (car lst)))
)
((= 4 (length lst))
(strcat (num->col (cadr lst))
(itoa (car lst))
":"
(num->col (last lst))
(itoa (caddr lst))
)
)
(t
"A1"
)
)
lst
)
)
(defun GetP (obj prop / Rtn Rtn2)
(cond ((= (type prop) 'sym)
(if(vl-catch-all-error-p(setq Rtn2(vl-catch-all-apply 'vlax-get-property (list obj prop) )))
(princ(strcat"\n不具备属性:" (vl-prin1-to-string(eval(quote prop))))) (setq Rtn Rtn2) )
)
((= (type prop) 'str)
(if (null (vl-string-search "." prop))
(if(vl-catch-all-error-p(setq Rtn2(vl-catch-all-apply 'vlax-get-property (list obj prop) )))
(princ(strcat"\n不具备属性:" prop)) (setq Rtn Rtn2) )
(foreach item (Str:Split prop ".")
(if (null Rtn)
(if(vl-catch-all-error-p(setq Rtn2(vl-catch-all-apply 'vlax-get-property (list obj item) )))
(princ(strcat"\n不具备属性:" item))(setq Rtn Rtn2) )
(if(vl-catch-all-error-p(setq Rtn2(vl-catch-all-apply 'vlax-get-property (list Rtn item) )))
(princ(strcat"\n不具备属性:" item))(setq Rtn Rtn2) )
)
)
)
)
)
(Excel-Utils-GetValue Rtn)
)
(defun PutP (obj prop value / Rtn Rtn2)
(cond ((= (type prop) 'sym)
(if(vl-catch-all-error-p(setq Rtn2(vl-catch-all-apply 'vlax-put-property (list obj prop value) )))
(princ(strcat"\n不可更改属性:" (vl-prin1-to-string(eval(quote prop))))) (setq Rtn Rtn2) )
)
((= (type prop) 'str)
(if (null (vl-string-search "." prop))
(if(vl-catch-all-error-p(setq Rtn2(vl-catch-all-apply 'vlax-put-property (list obj prop value) )))
(princ(strcat"\n不可更改属性:" prop)) (setq Rtn Rtn2) )
(progn
(setq items (Str:Split prop "."))
(foreach item (reverse(cdr(reverse items)))
(if (null Rtn)
(if(vl-catch-all-error-p(setq Rtn2(vl-catch-all-apply 'vlax-get-property (list obj item) )))
(princ(strcat"\n不具备属性:" item))(setq Rtn Rtn2) )
(if(vl-catch-all-error-p(setq Rtn2(vl-catch-all-apply 'vlax-get-property (list Rtn item) )))
(princ(strcat"\n不具备属性:" item))(setq Rtn Rtn2) )
)
)
(if(vl-catch-all-error-p(setq Rtn2(vl-catch-all-apply 'vlax-put-property (list Rtn (last items) value) )))
(princ(strcat"\n不可更改属性:" item)) )
)
)
)
)
)
(defun Str:Split (str del / pos)
(if (setq pos (vl-string-search del str))
(cons (substr str 1 pos)
(Str:Split (substr str (+ pos 1 (strlen del))) del)
)
(list str)
)
)
(defun Excel-Utils-GetValue (var)
(cond
((= 'list (type var))
(mapcar 'Excel-Utils-GetValue var)
)
((= 'variant (type var))
(Excel-Utils-GetValue
(vlax-variant-value
(if (member (vlax-variant-type Var) '(5 4 3 2));;;如果变体类型是双精度 单精度 长整型 整型
(setq Var (vlax-variant-change-type Var vlax-vbString));;;变体类型转换为字符串
var
)
)
)
)
((= 'safearray (type var))
(mapcar 'Excel-Utils-GetValue (vlax-safearray->list var))
)
(T var)
)
)
花开富贵 发表于 2023-9-1 15:45
这个写的不挺好吗，是不是觉得不简洁，多练练就好了
大神建议我不用open新建excel我用的vla对象新建的excel，然后就不会写了，下边是我想写的格式，就是想新建一个看不见的excel然后把数据写进去，然后另存一个名字，或者保存，然后关闭。中间获取数据的还是那些，但是就是不好使，不知道为啥。
;;;说明:新建Excel工作簿
(Defun BF-Excel-New (ishide / Rtn)
(if (setq Rtn (vlax-get-or-create-object "Excel.Application"))
(progn
(vlax-invoke
(vlax-get-property Rtn 'WorkBooks)
'Add
)
(if ishide
(vla-put-visible Rtn 1)
(vla-put-visible Rtn 0)
)
)
)
Rtn
)
;;;另存为excel文件
(Defun BF-Excel-SaveAs (XLApp Filename)
(vlax-invoke
(vlax-get-property XLApp "ActiveWorkbook")
"SaveAs"
Filename
)
)
;;:;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun XJB()
(vl-load-com)
(setq ff (BF-Excel-New nil)) ;新建excel文件
(setq i 0 ss '()) ;设置i初始值
(if (setq ss (ssget '((0 . "*TEXT")))) ;星号通配符，TEXT或者MTEXT都可以。
(repeat (sslength ss) ;对循环体中的表达式求SS图元个数值
(setq ssn (ssname ss i)) ;返回SS集中第i个图元名称
(setq ssdata (entget ssn)) ;返回图元的数据集
(setq txt (cdr (assoc 1 ssdata))) ;取文本数值
(setq txtxy (cdr (assoc 10 ssdata))) ;取文本坐标
(setq sx (rtos (nth 1 txtxy) 2 3)) ;将X坐标值实数转换成字符（目前没单独提取）
(setq sy (rtos (nth 0 txtxy) 2 3)) ;将y坐标值实数转换成字符（目前没单独提取）
(setq sz (rtos (nth 2 txtxy) 2 3)) ;将z坐标值实数转换成字符（目前没单独提取）
(setq tc (cdr (assoc 8 ssdata)))
(progn
(or
(setq col(cdr(assoc 62 ssdata)))
(setq col(cdr(assoc 62(tblsearch "layer" tc)))) ;随层颜色提取方式
)
col
)
(princ txt ff)
(princ "\t" ff);这个格式就是在同一行下一个内容
(princ txtxy ff)
(princ "\t" ff);这个格式就是在同一行下一个内容
(princ tc ff)
(princ "\t" ff);这个格式就是在同一行下一个内容
(princ col ff)
(princ "\t" ff);这个格式就是在同一行下一个内容
(princ "\n" ff);这个格式就换行
;write-line不用换行,princ要用/n换行,princ要用/t下一列，（在同一行下一个内容）
(setq i (1+ i))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(BF-Excel-SaveAs ff "C:\\Users\\administrator\\Desktop\\2.xlsx") ;另存excel文件并重命名为2
(close ff) ;关闭excel
(princ)
) ;;说明:我写了个提取cad中的文字、坐标、图层、颜色的程序，太不理想了（非常蹩脚）
(defun c:Q2(/ enames ff ss)
(setvar "cmdecho" 0) ;;关闭变量
(setvar "blipmode" 0);;关闭控制点
(vl-load-com) ;;加载vlax扩展函数
(setq excelapp(cond((vlax-get-or-create-object "excel.application")) ((vlax-get-or-create-object "ket.application"))))
(setq ss (ssget '((0 . "*TEXT"))))
(setq rowRela(sslength ss))
(setq enames (reverse(mapcar 'cadr (vl-remove-if-not '(lambda(x) (>= (car x) 0) )(ssnamex ss)))))
(Excel:WorkBooks-Add excelapp nil t)
(Excel:Range:Value-Put excelapp '(1 1 1 6) '("文字" "x坐标""y坐标""z坐标" "图层" "颜色"))
(Excel:Range:Value-Put excelapp (list 2 1 (+ 2 rowRela) 6)
(mapcar
'(lambda(x)
(setq ent$(entget x)
coor (cdr(assoc 10 ent$))
)
(list
(cdr(assoc 1 ent$))
(car coor)
(cadr coor)
(last coor)
(cdr(assoc 8 ent$))
(cdr(assoc 62 ent$)))
)
enames)
)
(princ"\n**********完成**********")
(princ)
)
自己知道怎么用的，达到目的就行，有空逛论坛看看例程例句，碎片化吸收学的快一些 (defun c:Q2(/ enames ff ss)
(setvar "cmdecho" 0) ;;关闭变量
(setvar "blipmode" 0);;关闭控制点
(vl-load-com) ;;加载vlax扩展函数
;(setq ffn (getfiled "写出文件" "C:/Users/Administrator/Desktop/" "csv" 1));弹对话框提示设置保存路径及名称
(princ "\n选取文字:") ;提示选取文字
(setq ff (open "C://Users//Administrator//Desktop//文字.xls""w")) ;建立文本;W会把文本里面的内容清除
(setq ss (ssget '((0 . "*TEXT"))))
(setq enames (reverse(mapcar 'cadr (vl-remove-if-not '(lambda(x) (>= (car x) 0) )(ssnamex ss)))))
(princ "文字 坐标 图层 颜色\n"ff)
(mapcar
'(lambda(x)
(setq ent$(entget x))
(princ (cdr(assoc 1 ent$)) ff)
(princ"\t" ff)
(princ (cdr(assoc 10 ent$)) ff)
(princ"\t" ff)
(princ (cdr(assoc 8 ent$)) ff)
(princ"\t" ff)
(princ (cdr(assoc 62 ent$)) ff)
(princ"\n" ff)
)
enames)
(close ff) ;
(princ)
) 楼上大神有宝物
可以搜搜 这个写的不挺好吗，是不是觉得不简洁，多练练就好了
可以分开写,一个程序是提取文本的数据为一列表,另一个程序是将列表输出到Excel中,这样程序的通用性会强一些.
建议你先熟悉一下ACAD的对象模型和Excel的对象模型 不会做gif，凑活预览吧
页:
[1]
2