能帮忙把导出Excel改成导出WPS吗，搞了好久没搞好
本帖最后由 wgij007 于 2021-3-6 10:41 编辑由于改不了，只好重发贴了。
CAD2006 WPS 2019
原输出office是没问题,不能输出WPS
;以下是由wzg356大师完成的代码:
(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 "Excel.Application"))
(vla-put-visible excel :vlax-true)
(setq lens(length lst));行数
(setq bks (vlax-get excel 'workbooks))
(setq acBook(vlax-invoke bks 'Add))
(setq sht(vlax-get excel 'ActiveSheet))
(setq rc (strcat "A1:"(excel:i2ColNo maxl)(itoa lens)));写表范围
(setq cells(vlax-get sht 'cells))
(setq range(vlax-get-property cells '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)
)
把Excel.Application 改为 ket.Application也不行
显视 VLA-OBJECT nil
试试这个，是否可以满足你的要求 。
导出后，默认程序打开，当然也可以是WPS
(defun C:TableOut(/ change_bom eliminate fdelete fname fp m nlm slm sort)
(defun sort(lxy / i lxy_n max_xy nxy xy_max xy_min);排序函数
(setq nxy (length lxy))
(setq xy_min (apply 'min lxy))
(setq xy_max (apply 'max lxy))
(setq max_xy (+ xy_max 10))
(setq lxy_n (list xy_min))
(setq lxy (subst max_xy xy_min lxy))
(setq i 0)
(while (< i (- nxy 1))
(setq xy_min (apply 'min lxy))
(setq lxy (subst max_xy xy_min lxy))
(setq lxy_n (cons xy_min lxy_n))
(if (= xy_min xy_max) (setq i nxy))
(setq i (+ i 1))
)
(setq lxy lxy_n)
)
(defun change_bom(/ ent et i j jd len lx lxc ly lyc n name nlh nlv ntxt stc str tab tj tx txt_ent ty x1 x2 y1 y2)
(setq jd 0.1)
(setq tab "\t")
(setq ntxt 0 nlv 0 nlh 0)
(setq lx () ly ())
(setq txt_ent (ssadd))
(setq n 0);序号的初值为0
(repeat nlm;重复执行，执行的次数等于所选对象的个数
(setq ent (ssname slm n));得到选择集内第n个对象的图元名
(setq et (entget ent));得到这个对象的图元表
(setq name (cdr (assoc 0 et)))
(if (or (= "TEXT" name) (= "MTEXT" name));判断这个对象是否为文本
(progn
(setq txt_ent (ssadd ent txt_ent))
(setq ntxt (+ ntxt 1))
)
)
(if (= "LINE" name);判断这个对象是否为直线
(progn
(setq x1 (nth 1 (assoc 10 et)))
(setq x2 (nth 1 (assoc 11 et)))
(setq y1 (nth 2 (assoc 10 et)))
(setq y2 (nth 2 (assoc 11 et)))
(setq lxc (fix (/ (+ x1 x2) 2)))
(setq lyc (fix (/ (+ y1 y2) 2)))
(if (< (abs (- x1 x2)) jd)
(setq lx (cons lxc lx))
)
(if (< (abs (- y1 y2)) jd)
(setq ly (cons lyc ly))
)
)
)
(setq n (+ n 1))
)
(setq lx (sort lx));将lx列表中的元素按顺序排列
(setq ly (sort ly));将ly列表中的元素按顺序排列
(setq lx (reverse lx))
(if (= m 1) (setq ly (reverse ly)))
(setq nlv (length lx))
(setq nlh (length ly))
(setq i 0)
(while (< i (- nlh 1))
(setq str "")
(setq j 0)
(while (< j (- nlv 1))
(setq n 0)
(while (< n ntxt)
(setq ent (ssname txt_ent n))
(setq et (entget ent))
(setq tx (nth 1 (assoc 10 et)))
(setq ty (nth 2 (assoc 10 et)))
(if (= m 1)
(setq tj (and (> ty (nth i ly)) (< ty (nth (+ i 1) ly))))
(setq tj (and (< ty (nth i ly)) (> ty (nth (+ i 1) ly))))
)
(if (and (> (+ tx 1) (nth j lx)) (< (+ tx 1) (nth (+ j 1) lx)) tj)
(progn
(setq txt_ent (ssdel ent txt_ent))
(setq ntxt (- ntxt 1))
(setq n ntxt)
(setq stc (cdr (assoc 1 et)))
(setq len (strlen stc))
(if (> len 2) (setq stc (eliminate stc len)))
)
)
(setq n (+ n 1))
)
(if (= n ntxt) (setq stc ""))
(setq str (strcat str stc))
(if (/= j (- nlv 2)) (setq str (strcat str tab)))
(setq j (+ j 1))
)
(write-line str fp)
(setq i (+ i 1))
)
)
(defun eliminate(strc stle / is js stre strq)
;消除strc中的"φ"和"×"
(if (> stle 7)
(progn
(setq strc (fdelete strc "\U+03C6"))
(setq strc (fdelete strc "\U+00D7"))
)
)
(if (> stle 2)
(progn
(setq strc (fdelete strc "\\P"))
(setq strc (fdelete strc "\t"))
(setq strc (fdelete strc "{"))
(setq strc (fdelete strc "}"))
)
)
;消除strc中"\...;"的内容
(setq is 1)
(while (< is stle)
(if (= (substr strc is 1) "\\")
(progn
(setq js (+ is 1))
(while (<= js stle)
(if (= (substr strc js 1) ";")
(progn
(setq strq (substr strc 1 (- is 1)))
(setq stre (substr strc (+ js 1)))
(setq strc (strcat strq stre))
(setq stle (strlen strc))
(setq js stle)
(setq is (- is 1))
)
)
(setq js (+ js 1))
)
)
)
(setq is (+ is 1))
)
(setq strc strc)
)
(defun fdelete(str1 str2 / k len1 len2 stle stre strk strq)
(setq len1 (strlen str1))
(setq len2 (strlen str2))
(if (>= len1 len2)
(progn
(setq k 1)
(while (< k (+ (- len1 len2) 2))
(setq strk (substr str1 k len2))
(if (= strk str2)
(progn
(setq strq (substr str1 1 (- k 1)))
(setq stre (substr str1 (+ k len2)))
(if (= str2 "\U+03C6")
(progn
(setq str1 (strcat strq "φ" stre))
(setq len1 (- len1 6))
)
)
(if (= str2 "\U+00D7")
(progn
(setq str1 (strcat strq "×" stre))
(setq len1 (- len1 6))
)
)
(if (= str2 "\\P")
(progn
(setq str1 (strcat strq stre))
(setq len1 (- len1 2))
)
)
(if (= str2 "\t")
(progn
(setq str1 (strcat strq stre))
(setq len1 (- len1 2))
)
)
(if (or (= str2 "{") (= str2 "}"))
(progn
(setq str1 (strcat strq stre))
(setq len1 (- len1 1))
)
)
)
)
(setq k (+ k 1))
)
)
)
(setq stle len1)
(setq str1 str1)
)
;以下部分为主程序
;(setvar "cmdecho" 0)
(setq fname (vl-filename-mktemp nil nil ".xls"))
(setq fp (open fname "a"))
(princ "\n请选择需要转换的表格：")
(setq slm (ssget));以交互方式得到一个选择集
(setq nlm (sslength slm))
(setq m (getdist "\n选择转换输出方式: 1-自下而上，2-自上而下[默认为2]"))
(if (not m) (setq m 2));如果m无定义（空响应），令m=2
(change_bom)
(close fp)
(command-s "_ai_editcustfile" fname)
;(setvar "cmdecho" 1)
(princ)
)
(princ)
nyistjz 发表于 2020-12-25 12:32
试试这个，是否可以满足你的要求 。
导出后，默认程序打开，当然也可以是WPS
这个程序有问题，错误 nyistjz 发表于 2020-12-25 12:32
试试这个，是否可以满足你的要求 。
导出后，默认程序打开，当然也可以是WPS
谢谢! nyistjz 分享程序, AUTOCAD2012 测试 O.K. wgij007 发表于 2020-12-25 20:47
这个程序有问题，错误
那你再试试另外的一个，如果还是不行，你得找一下，是不是自己电脑或者 CAD 哪里出问题了。
(defun c:c2e (/ @dclfiledame caotext fid fuzz hangdau index lst oldy sosanh ss ss2ent)
(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))
)
)
(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)
)
(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
@dclfiledame (vl-filename-mktemp nil nil ".csv")
fid (open @dclfiledame "w")
)
(vlax-invoke
(vlax-get-or-create-object "Wscript.Shell")
'RUN
@dclfiledame ;;(任意已经建立关联程序的文件)
)
(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)
)
这个可以收藏一下 nyistjz 发表于 2020-12-26 14:29
那你再试试另外的一个，如果还是不行，你得找一下，是不是自己电脑或者 CAD 哪里出问题了。
谢谢! nyistjz 分享程序, AUTOCAD2012 测试 O.K.
这程序比上一个程序快多了!!! nyistjz 发表于 2020-12-26 14:29
那你再试试另外的一个，如果还是不行，你得找一下，是不是自己电脑或者 CAD 哪里出问题了。
可以导出，但功能变了。还是想看能不能在原来的上面改.
多谢分享，复制留存 谢谢分享，收藏了
页:
[1]
2