[编程交流] 将文本从acad导出到excel

 
 ;;----------------------------TOXL.LSP-------------------------------;;
 ;; fixo ()2013 * all rights released
 ;; 03/11/13
 ;; edited 5/13/13
(defun c:TOXL(/ *error* as col cp data elist en fname gkw newpath nextaddress
         p1 p2 path rad row rownum setcelltext sheetname sset tmp
        xlapp xlbook xlbooks xlcell xlcells xlrange xlsheet xlsheets)
(vl-load-com)
 (defun *error* (msg)
 (if
   (vl-position
     msg
     '("console break"
"Function cancelled"
"quit / exit abort"
      )
   )
    (princ "Error!")
    (princ msg)
 )
 (princ)
)
(defun setcelltext(cells row column value)
 (vl-catch-all-apply
   'vlax-put-property
   (list cells 'Item row column
 (vlax-make-variant
   (vl-princ-to-string value) ))
 )
 
(if (and (setq p1 (getpoint "\nPick lower left point of area: "))
 (setq p2 (getcorner p1"\nOpposite corner: "))
 (setq sset (ssget "_W" p1 p2 (list (cons 0 "text");|(cons 8 "ANNO-TEXT")|)))
 
   (while (setq en (ssname sset 0))
     (setq elist (entget en))
     (setq cp (cdr (assoc 10 elist)))
     (setq txt (cdr (assoc 1 elist)))
     (setq tmp (list txt (rtos (cadr cp)3 2) (rtos (cadr cp) 3 2)  ))
     (setq data (cons tmp data))
     (ssdel en sset)))
(setq sheetname (getstring T "\nEnter the label of an area (like Area#1) : "))
 
 ;;; main part
(if data
(progn
(setq data (append (list (list "Text" "X" "Y")) (reverse data)))
 (alert "Wait...")
 (setq xlapp    (vlax-get-or-create-object "Excel.Application")
xlbooks  (vlax-get-property xlapp 'Workbooks)
xlbook    (vlax-invoke-method xlbooks 'Add)
xlsheets (vlax-get-property xlbook 'Sheets)
xlsheet    (vlax-get-property xlsheets 'Item 1)
xlcells    (vlax-get-property xlsheet 'Cells)
)
 (vlax-put-property xlsheet "Name" sheetname)
 
 (vla-put-visible xlapp :vlax-true)
 (setq row 1)
 
(foreach dim data
 (setq col 1)
(foreach i dim
(setcelltext xlcells row col (vl-princ-to-string i))
 (setq col (1+ col)
     )
 )
(setq row (1+ row)
     )
 )
 
(vlax-invoke-method
  (vlax-get-property xlsheet 'Columns)
  'AutoFit)
 
(setq fname (strcat (getvar "dwgprefix")(vl-filename-base (getvar "dwgname"))".xls"))
(vlax-invoke-method
   xlbook
   'SaveAs
   fname 
   nil
   nil
   nil
   :vlax-false
   :vlax-false
   1
   2
 )
(vlax-invoke-method
   xlbook 'Close)
 (gc)
(vlax-invoke-method
   xlapp 'Quit)
 (mapcar '(lambda (x)
     (vl-catch-all-apply
       '(lambda ()
   (vlax-release-object x)
 )
     )
   )
  (list xlcells xlsheet xlsheets xlbook xlbooks xlapp)
 )
 (setq  xlapp nil)
 (gc)(gc)
 (alert (strcat "File saved as:\n" fname))
 )
)
 (*error* nil)
 (princ)
 )
(prompt "\n\t\t---\tStart command with TOXL\t---\n")
(prin1)
(or (vl-load-com)
   (princ))