能帮忙把导出Excel改成导出WPS吗，搞了好久没搞好

wgij007

由于改不了，只好重发贴了。
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

nyistjz

试试这个，是否可以满足你的要求 。
导出后，默认程序打开，当然也可以是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)

wgij007

nyistjz 发表于 2020-12-25 12:32
试试这个，是否可以满足你的要求 。
导出后，默认程序打开，当然也可以是WPS

这个程序有问题，错误

yoyoho

nyistjz 发表于 2020-12-25 12:32
试试这个，是否可以满足你的要求 。
导出后，默认程序打开，当然也可以是WPS

谢谢! nyistjz 分享程序, AUTOCAD2012 测试 O.K.

nyistjz

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)
)

itoboy

这个可以收藏一下

yoyoho

nyistjz 发表于 2020-12-26 14:29
那你再试试另外的一个，如果还是不行，你得找一下，是不是自己电脑或者 CAD 哪里出问题了。

谢谢! nyistjz 分享程序, AUTOCAD2012 测试 O.K.
这程序比上一个程序快多了!!!

wgij007

nyistjz 发表于 2020-12-26 14:29
那你再试试另外的一个，如果还是不行，你得找一下，是不是自己电脑或者 CAD 哪里出问题了。

可以导出，但功能变了。还是想看能不能在原来的上面改.

sunny_8848

多谢分享，复制留存

hh_lj007

谢谢分享，收藏了