CAD表格输出Excel程序优化

seamopan

下面是CAD表格自动输出转为Excel表格的原程序，可以很好的实现转出功能，但是转出的速度太慢了，麻烦大侠帮忙优化下程序，可以提高转出的生产速度，谢谢！



;;;;选择集转表
(defun ss2lst (ss / i e lst)
(setq i -1)
(repeat (sslength ss)
  (setq e (ssname ss (setq i (1+ i)))
        lst (cons e lst)        ) ))
;;;;;删除重复元素
(defun deldump(lst / ret )
(vl-remove-if (function (lambda(x)(IF (NOT (MEMBER x RET))
(SETQ RET (CONS x RET))nil)))lst)
ret  )
;;;;;取精度
(defun fixnum(bl)
      (setq bl (/(fix (* bl (expt 10.0 3)))(expt 10.0 3)))   )
;;;;根据X、Y坐标（各为一个表）求点表
(defun getplst(lst1 lst2 / )
(if flag(setq oldlst1 lst1))
(repeat (1-(length lst2))
(if (and(cadr lst1)(cadr lst2))
  (progn
(setq flag nil)
(setq lst (append (list(list(list(car lst1)(car lst2))(list(car lst1)(cadr lst2))
                 (list(cadr lst1)(cadr lst2))(list(cadr lst1)(car lst2))    )            )
                   lst              )        )
(setq lst1(cdr lst1))
(if (and(cadr lst1)(cadr lst2)) (getplst lst1 lst2))           ;;;递归
)  )
(setq lst2(cdr lst2))
(if (cadr lst2)(setq lst1 oldlst1)(setq oldlst1 nil)) ) )
;;;excel输出函数,来源MJTD（局部有修改）
;;;  加载EXCEL类型库
(defun DSX-TypeLib-Excel (/ path tlb)
(setq obj (vlax-create-object "Excel.Application"))
(setq path (vlax-get-property obj 'Path))
(cond ((setq tlb (findfile (strcat path "\\Excel8.olb"))) tlb)
       ((setq tlb (findfile (strcat path "\\Excel9.olb"))) tlb)
       ((setq tlb (findfile (strcat path "\\Excel10.olb"))) tlb)
       ((setq tlb (findfile (strcat path "\\Excel.exe"))) tlb)
       (t
        (alert
         "本系统内未找到EXCEL97、2000、2002、2003、2010，初始化失败！"
        )       ) ))
;;;定义类型库接口
(defun DSX-Load-TypeLib-Excel (/ tlbfile tlbver out)
(cond
  ((null msxl-xl24HourClock)
   (if (setq tlbfile (DSX-TypeLib-Excel))                ;;;加载EXCEL类型库
    (progn
     (setq tlbver (substr (vl-filename-base tlbfile) 1 6))
     (cond ((= tlbver "10") (princ "\n初始化 Microsoft Excel 2002..."))
           ((= tlbver "9") (princ "\n初始化 Microsoft Excel 2000..."))
           ((= tlbver "8") (princ "\n初始化 Microsoft Excel 97..."))
           ((= (vl-filename-base tlbfile) "Excel")
            (princ "\n初始化 Microsoft Excel ...")
           )     )
     (vlax-import-type-library
      :tlb-filename      tlbfile
      :methods-prefix    "msxl-"
      :properties-prefix "msxl-"
      :constants-prefix  "msxl-"     )
     (if msxl-xl24HourClock
      (setq out T)     )    )   )  )
  (T (setq out T))  )
out)
;;;打开带有新的工作簿的 Excel
(defun DSX-Open-Excel-New (dmode / appsession)
(princ "\n创建一个新的 Excel 电子表格文件...")
(cond ((setq appsession (vlax-create-object "Excel.Application"))
        (vlax-invoke-method
         (vlax-get-property appsession 'WorkBooks)
         'Add        )
        (if (= (strcase dmode) "SHOW")
         (vla-put-visible appsession 1)
         (vla-put-visible appsession 0)        )       ) )
appsession  )
;;; 获取行<relrow> 和列 <relcol>范围内的单个单元格对象
(defun DSX-Excel-Get-Cell (rng relrow relcol)
(vlax-variant-value
  (msxl-get-item
   (msxl-get-cells rng)
   (vlax-make-variant relrow)
   (vlax-make-variant relcol)  ) ))
;;;将列表写到工作表指定行(startrow) 中的指定起始列(startcol)
(defun DSX-Excel-Put-RowList (lst startrow startcol)
(foreach itm lst
   (msxl-put-value2
   (DSX-Excel-Get-Cell range startrow startcol)
   itm  )
  (DSX-Excel-gridline2(DSX-Excel-Get-Cell range startrow startcol))          ;;为指定单个单元格对象添加外框;xiaxiang添加
(setq startcol (1+ startcol)) ) )
;;; 为指定单元格填入颜色
(defun DSX-Excel-Put-CellColor (row col intcol / rng)
(setq rng (DSX-Excel-Get-Cell (msxl-get-ActiveSheet xlapp) row col))
(msxl-put-colorindex (msxl-get-interior rng) intcol))
;;;为一行单元格填入颜色
(defun DSX-Excel-Put-RowCellsColor
       (startrow startcol cols intcol / next)
(setq next startcol)
(repeat cols
  (DSX-Excel-Put-CellColor startrow next intcol)
  (setq next (1+ next))  )  )
;;;为选中的范围的实行自动调整宽度
(defun DSX-Excel-RangeAutoFit (active-sheet)
(vlax-invoke-method
  (vlax-get-property
   (vlax-get-property
    (vlax-get-property active-sheet 'UsedRange)
    'Cells   )
   'Columns  )
  'AutoFit   )  )
;;;为选中的范围的实行网格线（自加）
;;;修改
;;详见VBA-->Range.BorderAround 帮助
(defun DSX-Excel-gridline1 (active-sheet)
  (vlax-invoke-method
    (vlax-get-property active-sheet 'UsedRange)
  'BorderAround
  msxl-xlContinuous msxl-xlMedium
  1                  ;;color号，1代表黑色或自动
) )
;;;为选中的单元格对象实行网格线（自加）
;;;添加
;详见VBA-->Range.BorderAround 帮助
(defun DSX-Excel-gridline2 (active-cell)
  (vlax-invoke-method active-cell
  'BorderAround
  msxl-xlContinuous msxl-xlThin  
  1                   ;;color号，1代表黑色或自动
) )
;;;退出并关闭Excel进程
(defun DSX-Excel-Quit (appsession)
(cond ((not (vlax-object-released-p appsession))
             (vlax-release-object appsession)       ) ))
;;;输出到excel
(defun tjwb( lst / plst ss n txt lst1 lst2 m lst3 lst_bzmp i lst4 lst5)
(setq m 0)
(foreach x lst
    (setq ss(ssget "wp" x '((0 . "*TEXT"))))
    (if (not ss)(setq ss(ssget "Cp" x '((0 . "*TEXT")))))
    (SETQ N 0 txt "")
  (if (and ss (< N (SSLENGTH SS)))
   (progn
    (WHILE (and ss (< N (SSLENGTH SS)))
    (setq txt(strcat (CDR(ASSOC 1 (ENTGET (SSNAME SS N))))txt ))
    (SETQ LST1 (LIST txt))
    (SETQ N (1+ N))    )    )
    (progn
    (setq txt "")
    (SETQ LST1 (LIST txt))    )   )
   (if (< m (1- lencolumn))
    (progn
     (SETQ lst2 (APPEND lst2 lst1))    )
    (setq lst3 (APPEND lst3(list lst2)) m 0 lst2 lst1 lst1 nil)    )
   (setq m(1+ m))    )
   (setq lst3 (APPEND lst3(list lst2)))
(DSX-Load-TypeLib-Excel)
(cond ((setq xlapp(DSX-Open-Excel-New "SHOW")
             ash (msxl-Get-ActiveSheet xlapp)
             range (msxl-Get-ActiveCell xlapp)           )       ) )
(setq numrow 1 i 0)
(mapcar (function(lambda(x)(DSX-Excel-Put-RowList x numrow 1)
                 (DSX-Excel-Put-rowCellsColor 1 1 (length (car lst3)) 42)        ;;;颜色数字
                 (setq i (1+ i) numrow (1+ numrow))                 )              )
        lst3        )
(DSX-Excel-RangeAutoFit ash)
(DSX-Excel-gridline1 ash)
(DSX-Excel-Quit ash) )
;;;;;;主程序
(defun c:c2e1(/ p1 p2 ss e dxf10 dxf11 lstp1 lstp2 ss2elst lst plst oldlst2
         lstp3 lstp4 fuzz ang dxf txtSS txt txtlst lenrow lencolumn)
  (VL-LOAD-COM)
  (setq p1 (getpoint"\n请框选要导出EXCEL的表格")
        p2(getcorner p1 "\n请框选要导出EXCEL的表格")
        )
(setq ss(ssget "c" p1 p2 '((0 . "LINE")))n -1 fuzz 1e-3)
(repeat (sslength ss)
   (setq e(ssname ss (setq n(1+ n)))
         dxf(entget e)
         dxf10(cdr(assoc 10 dxf))
         dxf11(cdr(assoc 11 dxf))
         ang(angle dxf10 dxf11)   )
   (cond((or(equal ang 0. fuzz)(equal ang pi fuzz))
         (setq lstp1(append lstp1 (list(list dxf10 dxf11))))                    ;;;(redraw e 3)        
                )
        ((equal  (rem ang pi ) 3.14159 fuzz)
         (setq lstp1(append lstp1 (list(list dxf11 dxf10))))                    ;;;(redraw e 4)
         )
         ((or(equal ang (* pi 0.5) fuzz)(equal ang (* pi 1.5) fuzz))
          (setq lstp2(append lstp2 (list(list dxf10 dxf11))))         )
         ((equal  (rem ang pi ) 1.5708 fuzz)
          (setq lstp2(append lstp2 (list(list dxf11 dxf10))))         )   )  )
  (setq lenrow (length (setq lstp3
         (vl-sort
         (deldump (mapcar '(lambda (x) (fixnum (cadar x))) lstp1))
         '<         )              )              )
       lencolumn (length (setq lstp4
(vl-sort
(deldump (mapcar '(lambda (x) (fixnum (caar x))) lstp2))
'>      )           )      ) )
(setq flag t)
(getplst lstp4 lstp3)
(setq plst lst lst nil txtlst (tjwb plst))
(princ) )
(princ "\nCAD线表格导出到EXCEL，仅支持直线；命令c2e.")
(princ)

lxl217114

可以直接用强总的
http://bbs.mjtd.com/thread-178805-1-1.html

seamopan

lxl217114 发表于 2022-10-29 14:19
可以直接用强总的
http://bbs.mjtd.com/thread-178805-1-1.html

强总这个表格导出很快，但在有空格的情况下导出到Excel中容易表格内容错位，而且表格长度不能随格中内容长短调整表格长度，如果能完善这两个问题就很好了；

664571221

seamopan 发表于 2022-10-29 20:52
强总这个表格导出很快，但在有空格的情况下导出到Excel中容易表格内容错位，而且表格长度不能随格中内容 ...

用易楼的...

seamopan

664571221 发表于 2022-10-30 15:04
用易楼的...

大佬，有相关的链接发上来吗？我搜了半天好像没找到啊