那你再试试另外的一个，如果还是不行，你得找一下，是不是自己电脑或者 CAD 哪里出问题了。
这个不错，CAD2014成功 nyistjz 发表于 2020-12-25 12:32
试试这个，是否可以满足你的要求 。
导出后，默认程序打开，当然也可以是WPS
这个CAD2014也成功，默认office打开 本帖最后由 yuanziyou 于 2021-1-4 21:16 编辑
主要修改了这一句：(setq acBook (vlax-invoke bks 'add -4167));;-4167表示用模板新建
先测试一下ok不ok啊？
(defun Mtext2Lstr (en / e lstr)
(setq en(entmakex(entget en)))
(setvar "cmdecho" 0)
(command "_explode" en)
(setvar "cmdecho" 0)
(while
(setq e(entnext en))
(setq str(cdr(assoc 1(entget e))))
(entdel e)
(setq lstr(append Lstr(list str)))
)
)
;*************************
;;;表快速输出 XLS
;lst表一行一子表，一格一元素
;(ls2xls (list (list "x" "y" 3)(list 1 "" 3)))
(defun ls2xls (lst / Excel:i2ColNo lens maxl x excel bks acBook sht rc cells range)
(defun Excel:i2ColNo (a / l _i2ColNo)
(defun _i2ColNo (num / lst)
(cond((<= 1 num 26)(setq lst(cons num lst)))
((> num 26)(setq lst(append(_i2ColNo (/ num 26))(list(rem num 26)))))
(t lst)
) lst
)
(if (and(>= (setq a(fix(abs a)))1)(setq l(_i2ColNo a)))
(apply 'strcat(mapcar '(lambda (x)(chr(+ 64 x)))l))
)
);整数转EXCEL的列编号
(setq lens(mapcar 'length lst))
(setq maxl(apply 'max lens))
(if (not(apply '= lens))
(setq lst(mapcar '(lambda(x)
(repeat(- maxl(length x))(setq x(append x(list "")))) x)lst)
);子表不等长的用""补齐
)
(setq excel (vlax-get-or-create-object "ket.Application"));;wps
;(setq excel (vlax-get-or-create-object "Excel.Application"));;excle
(vla-put-visible excel :vlax-true)
(setq lens(length lst));行数
(setq bks (vlax-get-property excel 'Workbooks))
(setq acBook (vlax-invoke bks 'add -4167));;-4167表示用模板新建
(setq sht(vlax-get-property acBook 'ActiveSheet))
(setq rc (strcat "A1:"(excel:i2ColNo maxl)(itoa lens)));写表范围
(setq range(vlax-get-property sht 'Range rc))
(vlax-put-property range'value2
(vlax-safearray-fill
(vlax-make-safearray vlax-vbstring
(cons 1 lens)(cons 1(length (car lst)))
)lst
)
)
;(vlax-put-property (vlax-get-property sht "Range" "A:A") "ColumnWidth" 20);列宽20
;(vlax-put-property (vlax-get-property sht "Range" "1:1") "RowHeight" 30);行高30
)
;**************************************
(vl-load-com)
(defun c:mt2xls( / ss en lstr)
(and(setq ss(ssget'((0 . "mtext"))))
(setq ss(vl-remove-if 'listp(mapcar 'cadr (ssnamex ss))))
(foreach en ss
(setq lstr(append lstr(list(Mtext2Lstr en))))
)
(ls2xls lstr)
)
(princ)
)
yuanziyou 发表于 2021-1-4 21:15
主要修改了这一句：(setq acBook (vlax-invoke bks 'add -4167));;-4167表示用模板新建
先测试一下ok不ok ...
不行呀,还是谢谢 顶一下，看能不能有帮忙解决的 MARK MARKMARK
页:
1
[2]