[求助]：高手：用lisp编一个cad与excel导入的功能

xxming

谁能用lisp编一个能把cad中的表格和文字导入excel中这个功能的程序，论坛中的软件都要注册或者没有这个功能我只需要这个功能即可，谢谢

snoopychen

以前编过表格导出文本的程序，前天开始学和其他程序的连接，试着编了下面这个程序
帮忙看看是否能用，现在不是很确定不同版本的excel有什么问题没有：）
[php]
;;; 提取cad表格到excel中的程序，功能比较简单，效率比较低
;;; by qjchen
;;; 练练手而已，功能比较弱，建议大家用truetable：）
;;; 要求r2000以上，要求所有的文本在格子中，每个格子只有一个文本，文本可在格
;;; 子内任何位置，要求非常规则的表格，表格从上到下的列数都一致?
;;; 所以选择的时候最好不要选择标题栏
;;; 编程思路：沿左上角画两条线，和表格相交得到表格的各列宽度和各行高度，循?
;;; 环选取文本到表中
;;; 待改进的地方:争取不要那么多废话让自己选择文件名，不断选择则不断往一个
;;; excel里面存，直到不想要为止
;;; 我个人还是比较喜欢存到txt中，而非直接到excel

(defun c:b2e (/ p1 p2 p3 p4 p1a p2a p1b p4b pvlist phlist palllist newpvlist
                i j column row ss palist en ed ttext fn fh
             )
  (setvar "osmode" 33)
  (setq p1 (getpoint "\n左上角点："))
  (setq p3 (getpoint "\n右下角点："))
  (setvar "osmode" 0)
  (setq p2 (list (car p1) (car (cdr p3)) 0))
  (setq p4 (list (car p3) (car (cdr p1)) 0))
  (setq p1a (polar p1 0 1))
  (setq p2a (polar p2 0 1))
  (setq p1b (polar p1 (* pi 1.5) 1))
  (setq p4b (polar p4 pi 1))               ; 纵向交点集pvlist
  (setq pvlist (vl-Get-Int-Pt p1a p2a))
  (setq pvlist (mapcar
                 '(lambda (x)
                    (polar x pi 1)
                  )
                 pvlist
               )
  )                                       ; 横向交点集phlist
  (setq phlist (vl-Get-Int-Pt p1b p4b))
  (setq palllist (list pvlist))
  (setq i 1)
  (repeat (- (length phlist) 1)
    (setq newpvlist (mapcar
                      '(lambda (x)
                         (list (car (nth i phlist)) (car (cdr x))
                               (car (cddr x))
                         )
                       )
                      pvlist
                    )
    )
    (setq palllist (append
                     palllist
                     (list newpvlist)
                   )
    )
    (setq i (1+ i))
  )
  (setq column (length palllist))
  (setq row (length (nth 0 palllist)))
  (setq j 0)
  (setq finallist nil)
  (repeat (- row 1)
    (setq i 0
          rowlist nil
    )
    (repeat (- column 1)
      (setq pa1 (nth j (nth i palllist)))
      (setq pa2 (nth (1+ j) (nth i palllist)))
      (setq pa3 (nth (1+ j) (nth (1+ i) palllist)))
      (setq pa4 (nth j (nth (1+ i) palllist)))
      (setq palist (list pa1 pa2 pa3 pa4))
      (SETQ SS (SSGET "WP" palist))
      (if (/= ss nil)
        (progn
          (SETQ EN (SSNAME SS 0))
          (SETQ ED (ENTGET EN))
          (setq ttext (cdr (assoc 1 ed)))
          (setq rowlist (append
                          rowlist
                          (list ttext)
                        )
          )
        )
        (setq rowlist (append
                        rowlist
                        (list " ")
                      )
        )
      )
      (setq i (1+ i))
    )
    (setq finallist (append
                      finallist
                      (list rowlist)
                    )
    )
    (setq j (1+ j))
  )                                       ; 此时得到的finallist就已经是所有文?
                                       ; ?
                                       ; 按先行后列的二维表了
  (setq outlist finallist)               ; 调用写入表格到excel中的子程序
  (blcx outlist)



)


;;; 引用一个韩国朋友写的关于两点和多个物体交点的程序
(defun vl-Get-Int-Pt (FirstPoint SecondPoint / acadDocument mSpace SSetName
                                 SSets SSet reapp ex obj Baseline
                     )
  (vl-load-com)
  (setq acadDocument (vla-get-ActiveDocument (vlax-get-acad-object)))
  (setq mSpace (vla-get-ModelSpace acadDocument))
  (setq SSetName "MySSet")
  (setq SSets (vla-get-SelectionSets acadDocument))
  (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list SSets
                                                               SSetName
                                                         )
                            )
      )
    (vla-clear (vla-Item SSets SSetName))
  )
  (setq SSet (vla-Item SSets SSetName))
  (setq Baseline (vla-Addline mspace (vlax-3d-point FirstPoint)
                              (vlax-3d-point SecondPoint)
                 )
  )
  (vla-SelectByPolygon SSet acSelectionSetFence
                       (kht:list->safearray (append
                                              FirstPoint
                                              SecondPoint
                                            ) 'vlax-vbdouble
                       )
  )
  (vlax-for obj sset (if (setq ex (kht-intersect
                                                 (vlax-vla-object->ename BaseLine)
                                                 (vlax-vla-object->ename obj)
                                  )
                         )
                       (setq reapp (append
                                     reapp
                                     ex
                                   )
                       )
                     )
  )
  (vla-delete BaseLine)
  (setq reapp (vl-sort reapp '(lambda (e1 e2)
                                (< (car e1) (car e2))
                              )
              )
  )
  reapp
)


;;; 修改了一点，让text和其他的没有交点
(defun kht-intersect (en1 en2 / a b x ex ex-app c d e)
  (vl-load-com)
  (setq c (cdr (assoc 0 (entget en1)))
        d (cdr (assoc 0 (entget en2)))
  )
  (if (or
        (= c "TEXT")
        (= d "TEXT")
      )
    (setq e -1)
  )
  (setq En1 (vlax-ename->vla-object En1))
  (setq En2 (vlax-ename->vla-object En2))
  (setq a (vla-intersectwith en1 en2 acExtendNone))
  (setq a (vlax-variant-value a))
  (setq b (vlax-safearray-get-u-bound a 1))
  (if (= e -1)
    (setq b e)
  )
  (if (/= b -1)
    (progn
      (setq a (vlax-safearray->list a))
      (repeat (/ (length a) 3)
        (setq ex-app (append
                       ex-app
                       (list (list (car a) (cadr a) (caddr a)))
                     )
        )
        (setq a (cdr (cdr (cdr a))))
      )
      ex-app
    )
    nil
  )
)

(defun kht:list->safearray (lst datatype)
  (vlax-safearray-fill (vlax-make-safearray (eval datatype) (cons 0
                                                                  (1-
                                                                      (length lst)
                                                                  )
                                                            )
                       ) lst
  )
)

;;; CADALYST 01/05 Tip2015: BLCX.lsp        Block counter        (c) Alexander Smirnov，
;;; asmirnov@inbox.lv
;;; 本程序改自cadalyst上面的程序，程序原来是用于统计图中的块体名称和数量，?
;;; 改动了一下之后
;;; 现在用于输出二维表到相应的格子中，由于学cad与其他程序连接才2天，
;;; 这个水平很烂，有待进一步体会之后再作调整

(defun blcx (outlist / blSet blList nameList listLen outList exFlag
                     oldExFlag exPath exApp exWorkbook exFileexSheets
                     exSheet curId newFile curCell curVal
            )

  (setq list1 (conexcelcolumn))
  (vl-load-com)
  (textscr)
  (if (not exFlag)
    (setq exFlag "N")
  )
  (setq oldExFlag exFlag)
  (initget "Y N")
  (setq exFlag (getkword (strcat "\n\n*** Save report to MS Excel file? [Y/N] <"
                                 exFlag ">: "
                         )
               )
  )
  (if (null exFlag)
    (setq exFlag oldExFlag)
  )
  (if (= exFlag "Y")
    (progn
      (if (setq exPath (getfiled "Save Text File As" (strcat
                                                             (getvar "dwgprefix")
                                                             (substr
                                                                     (getvar "dwgname")
                                                                     1
                                                                     (-
                                                                        (strlen
                                                                                (getvar "dwgname")
                                                                        ) 4
                                                                     )
                                                             ) ".xls"
                                                     ) "xls" 33
                       )               ; end getfiled






          )                               ; end setq
        (progn
          (setq exApp (vlax-create-object "Excel.Application"))

          (if (null exApp)
            (progn
              (alert "Error. Can't start MS Excel.")
              (quit)
            )

          )                               ; end if
                                       ; end
                                       ; progn，这里才是和excel连接的关键，
                                       ; 这里主要用invoke就可以省去不少功夫?
                                       ; 假如不想要太多功能的话，invoke也差不多了
          (setq exWorkbook (vlax-get-property exApp "Workbooks")
                exFile (vlax-invoke-method exWorkbook "Add")
                exSheets (vlax-get-property exFile "Worksheets")
                exSheet (vlax-get-property exSheets "Item" "Sheet1")
                curRow 2
          )                               ; end setq，从第二行开始
                                       ; 循环写入excel?
          (repeat (length outList)
            (setq temp 1)
            (repeat (length (nth 0 outlist))
              (setq curId (strcat (nth temp list1) (itoa curRow))
                    curCell (vlax-variant-value (vlax-invoke-method exSheet "Evaluate"
                                                                    curId
                                                )
                            )
                    curVal (nth (1- temp) (nth (- curRow 2) outList))
              )                               
;;; end
;;; setq这个B代表的是excel中的B列，curid就是B3之类的意思，
;;;curcell是一个activex类型，curval是要写入的数值

              (vlax-put-property curCell "Formula" curVal)
              (vlax-release-object curCell)
              (setq temp (1+ temp))
            )

            (setq curRow (1+ curRow))
          )                               ; end repeat
          (vlax-invoke-method exFile "SaveAs" exPath nil nil nil nil nil nil)
          (vlax-invoke-method exFile "Close" nil)
          (vlax-invoke-method exApp "Quit")
          (mapcar
            (function (lambda (x)
                        (if (and
                              x
                              (not (vlax-object-released-p x))
                            )
                          (vlax-release-object x)
                        )
                      )
            )
            (list curCell exSheet exSheets exFile exWorkbook exApp)
          )
          (setq curCell nil
                exSheet nil
                exSheets nil
                exFile nil
                exWorkbook nil
                exApp nil
          )                               ; end setq
          (gc)
        )
      )                                       ; end if
    )                                       ; end progn

  )                                       ; end if


)
;;; end of BLCX

;;;产生一个和excel的列对应的表格
(defun conexcelcolumn (/ a b list1)
  (setq a 65)
  (setq list1 nil)
  (repeat 26
    (setq list1 (append
                  list1
                  (list (chr a))
                )
    )
    (setq a (1+ a))
  )
  (setq a 65)
  (repeat 26
    (setq b 65)
    (repeat 26
      (setq list1 (append
                    list1
                    (list (strcat (chr a) (chr b)))
                  )
      )
      (setq b (1+ b))
    )
    (setq a (1+ a))
  )

  list1
)

[/php]

xxming

二楼：谢了。你这样的程序我自己也编过一个没有象你编得这么复杂，但我想是否能够直接与excel导入不用先转为txt文本?

eachy

最初由 xxming 发布
[B]二楼：谢了。你这样的程序我自己也编过一个没有象你编得这么复杂，但我想是否能够直接与excel导入不用先转为txt文本? [/B]

反过来用吧，表格在 Excel 中制作，在CAD中粘贴为OLE实体，可以双击直接进入Excel，省得倒来倒去

xxming

eachy 斑竹，你能否给我编一个在cad中拾取多义线后，可以直接在execl中把角点坐标x和y列出来，并且在cad中的多义线自动对角点进行编号.谢谢，(我自动编了一个但不能导入execl中)

eachy

最初由 xxming 发布
[B]eachy 斑竹，你能否给我编一个在cad中拾取多义线后，可以直接在execl中把角点坐标x和y列出来，并且在cad中的多义线自动对角点进行编号.谢谢，(我自动编了一个但不能导入execl中) [/B]

把你写的贴上来吧，交流使人进步

xxming

eachy能否拾取多义线把坐标直接导入excel不用先转txt文本
(命令plt)

eachy

第一次写这种连接的程序，命令 GetCoords，注意本程序生成后不退出 Excel 。中途 ESC 后内存可能驻留 Excel 进程。

xxming

你的效率真是太高了真是历害。能否进行修改：1、在excel中把x和y坐标互换（因为是工程坐标与cad相反)2、把"编号"改为角点。3、另外，能否支持多次拾取对象并进行编号。太感谢了向你致敬、学习.

eachy

重新下载附件

xxming

eachy斑竹可以用了。是否方便把代源传给我谢谢，如不方便就不用了diablo_xie@yahoo.com.cn

snoopychen

三楼楼主，好像我的程序没有先导入txt文本啊，本来就是直接进入excel的啊
它只是先存到一个List里面而已。
我再学学eachy版主的程序，看看怎么样好些：）

xxming

12楼：我上次好象看过你先转成文本再导入excel，没注意到你的程序改动，再此谢谢，你的lisp水平也很高了希望你再完善一下程序以后有机会多多和你交流

snoopychen

xxming，你好：），有空多交流，共同进步。
我也是最近才学excel连接的，水平比较低，最近把转换表格的程序改的比较合心意了。感觉没有太多的滞后了。当然离truetable还有挺远的距离，至少它那些不同宽度和高度的变化我就觉得很头痛，那些可能得找一条直线不断的对表格进行扫描，才能得到一个相同的表格系统，由于和我没有什么关系，所以也不会往这方向去发展，毕竟lisp只是一个业余爱好，不值得花太多时间对它。
这几天为了学习eachy版主上面这个程序，学习了一下excel，争取编的比较象的结果，所以得到下面的程序，语句很罗嗦的
[php]
(defun c:test (/ cout ent_obj outlist dlist elist clist b nleng)
  (setq count 1)
  (setq clist (list "角点" "X坐标" "Y坐标"))
  (while (setq b (entsel "\n请选择一条多义线"))
    (setq ent_obj (entget (car b)))
    (setq outlist (w_pl_lst ent_obj))
    (setq dlist (append
          dlist
          outlist
        )
    )
  )
  (setq nleng (length dlist))
  (repeat nleng
    (setq elist (append
          elist
          (list (itoa count))
        )
    )
    (setq count (1+ count))
  )
  (setq outlist (mapcar
          'cons
          elist
          dlist
        )
  )
  (setq outlist (append
          (list clist)
          outlist
        )
  )
  (2xl outlist)
  (prompt "\n坐标已经输出")
)



;;; 初始化excel，注入几个常用参数，假如excel已经启动就让它visible，以后就不
;;;visible了
(defun IniciaExcel (/ m)
  (vl-load-com)
  (setq m (vlax-get-or-create-object "excel.application"))
  (if (= (vla-get-visible m) :Vlax-false)
    (vla-put-visible (vlax-get-or-create-object "excel.application") T)
  )
  (setq *Excel* (vlax-get-or-create-object "excel.application")
    *workbooks* (vlax-get-property *Excel* "workbooks")
    *add* (vlax-invoke-method *workbooks* "add")
    *sheets* (vlax-get-property *add* "sheets")
    *item* (vlax-get-property *sheets* "item" 1)
    *cells* (vlax-get-property *item* "cells")
  )
  (if (= (vlax-get-object "Excel.Application") nil)
    (progn
      (vla-put-visible *Excel* T)
    )
  )
)

;;; 释放excel进程
(defun TerminaExcel ()
  (vlax-release-object *cells*)
  (vlax-release-object *item*)
  (vlax-release-object *sheets*)
  (vlax-release-object *add*)
  (vlax-release-object *workbooks*)
  (vlax-release-object *Excel*)
)

;;; 这个把二维表写入到对应的excel表格中
(defun 2xl (outlist / temp val cll rll cel ccel ccell)
  (IniciaExcel)
  (setq list1 (conexcelcolumn))
  (setq curRow 2)
  (repeat (length outList)
    (setq temp 1)
    (repeat (length (nth 0 outlist))
      (setq val (nth (1- temp) (nth (- curRow 2) outList)))
      (setq cll (nth temp list1))
      (setq rll (itoa curRow))
      (setq cel (strcat cll rll))
      (setq curId (strcat (nth temp list1) (itoa curRow))
        curCell (vlax-variant-value (vlax-invoke-method *item*
                                "Evaluate" curId
                    )
            )
        curVal (nth (1- temp) (nth (- curRow 2) outList))
      )
      (vlax-put-property curCell "Formula" curVal)
      (vlax-release-object curCell)
      (setq temp (1+ temp))
    )
    (setq curRow (1+ curRow))
  )
  (TerminaExcel)
  ;(princ)
)


;;; 产生一个和excel的列对应的表格
(defun conexcelcolumn (/ a b list1)
  (setq a 65)
  (setq list1 nil)
  (repeat 26
    (setq list1 (append
          list1
          (list (chr a))
        )
    )
    (setq a (1+ a))
  )
  (setq a 65)
  (repeat 26
    (setq b 65)
    (repeat 26
      (setq list1 (append
            list1
            (list (strcat (chr a) (chr b)))
          )
      )
      (setq b (1+ b))
    )
    (setq a (1+ a))
  )

  list1
)


;;; 多义线的顶点坐标输出为表
(defun w_pl_lst (ent / pl_list elv pnt pnt1 ent)
  (setq pl_list nil)
  (if (= (cdr (assoc 38 ent)) nil)
    (setq elv 0.0)
    (setq elv (cdr (assoc 38 ent)))
  )
  (foreach rec ent
    (if (= (car rec) 10)
      (progn
    (setq pnt (cdr rec))
    (setq pnt1 (list pnt))
    (setq pl_list (append
            pnt1
            pl_list
              )
    )

      )
    )
  )
  pl_list
)
[/php]

xxming

snoopychen 恭喜你写出程序了。但程序运行错误提示：“请选择一条多义线 ; 错误: 参数类型错误: numberp: nil”你再检查一下