CAD表格坐标X，Y，Z
你好请用任何LISP将CAD表格坐标X、Y、Z转换为EXCEL？
提前谢谢
amr公司
试试这样的
(vl-load-com)
;; local defuns
(defun get_table_content (atable/ col cols data
datum hastile row rows start
tmp
)
(setq cols(vla-get-columns atable)
rows(vla-get-rows atable)
start rows
)
(if (eq :vlax-true (vla-get-titlesuppressed atable))
(progn
(setq rows (1- rows))
(setq hastile T)
(setq hastile nil)
)
)
(if (eq :vlax-true (vla-get-headersuppressed atable))
(setq rows (1- rows))
)
(setq row (- start rows))
(repeat rows
(setq col 0)
(repeat cols
(setq datum (vla-gettext atable row col))
(setq tmp (cons datum tmp))
(setq col (1+ col))
)
(setq data (cons (reverse tmp) data)
tmpnil
row(1+ row)
)
)
(setq data (reverse data))
(if hastile
(setq data (append (list (caar data) (cdr data))))
)
data
)
(defun merge_first_row (xlsht columns / adr rng)
(setq adr (strcat "A1:" (chr (+ 65 (1- columns))) "1"))
(setq rng (vlax-get-property xlsht 'Range adr))
(vlax-put-property
rng
'HorizontalAlignment
(vlax-make-variant -4108 vlax-vbinteger)
) ;1
(vlax-put-property
rng
'VerticalAlignment
(vlax-make-variant -4107 vlax-vbinteger)
) ;2
(vlax-put-property rng 'WrapText (vlax-make-variant -1 11)) ;3
(vlax-put-property
rng
'Orientation
(vlax-make-variant -4128 vlax-vbinteger)
) ;4
(vlax-put-property rng 'AddIndent (vlax-make-variant -1 11)) ;5
(vlax-put-property
rng
'IndentLevel
(vlax-make-variant 0 vlax-vbinteger)
) ;6
(vlax-put-property
rng
'ShrinkToFit
(vlax-make-variant -1 11)
) ;7
(vl-catch-all-apply
(function (lambda ()
(vlax-put-property
rng
'MergeCells
(vlax-make-variant -1 11)
)
)
)
) ;8
(vlax-put-property
rng
'ReadingOrder
(vlax-make-variant -5002 vlax-vbinteger)
) ;9
(vlax-invoke rng 'Merge)
(vlax-release-object rng)
(setq rng nil)
)
(defun draw-grid (xlapp xlsht / a bords cnt rng sel)
(setq rng (vlax-get-property xlsht 'UsedRange))
(vlax-invoke-method rng 'Select)
(setq sel (vlax-get-property xlapp 'Selection))
(setq bords (vlax-get-property sel "Borders"))
;; iterate through all edges of selection
(setq cnt 0)
(vlax-for a bords
(setq cnt (1+ cnt))
(vl-catch-all-apply
(function (lambda ()
(progn
(if (< cnt 5)
(progn
(vlax-put-property
a
"LineStyle"
(vlax-make-variant 1 3)
)
(vlax-put-property
a
"Weight"
(vlax-make-variant 4 3)
)
(vlax-put-property
a
"ColorIndex"
(vlax-make-variant 5 5)
)
) ;progn
;; turn off the diagonal lines:
(vlax-put-property
a
"LineStyle"
(vlax-make-variant -4142 3)
)
)
)
)
)
)
)
(vlax-release-object rng)
(vlax-release-object sel)
)
;; main part
;; based on rouitine written byAlejandro Leguizamon
(defun C:LX (/ adoc atablecol columns data en
ent mergedrow rows xlapp xlbks xlcls
xlcolsxlrng xlsht xlshtsxlwbk
)
(or (vl-load-com))
(or adoc
(setq adoc
(vla-get-activedocument
(vlax-get-acad-object)
)
)
)
(if (and
(setq ent (entsel "\nSelect table >>"))
(equal "ACAD_TABLE"
(cdr (assoc 0 (entget (setq en (car ent))))
)
)
)
(progn
(setq atable (vlax-ename->vla-object en))
(setq data (get_table_content atable))
(setq xlapp(vlax-get-or-create-object "Excel.Application")
xlbks(vlax-get-property xlapp "Workbooks")
xlwbk(vlax-invoke-method xlbks "Add")
xlshts (vlax-get-property xlwbk "Sheets")
xlsht(vlax-get-property xlshts "Item" 1)
xlcls(vlax-get-property xlsht "Cells")
)
(vla-put-visible xlapp :vlax-true)
(setq row 0)
(setq columns (length (last data))
rows (length data)
)
(if (= 1 (length (vl-remove-if (function (lambda(x)(equal "" x)))(car data))))
(setq merged T)
(setq merged nil)
)
(if merged
(progn
(setq row (1+ row))
(vlax-put-property
xlcls
"Item"
row
1
(vl-princ-to-string (caar data))
)
(setq data (cdr data))
(foreach lst data
(setq row (1+ row)
col 1
)
(foreach itm lst
(vlax-put-property
xlcls
"Item"
row
col
(vl-princ-to-string itm)
)
(setq col (1+ col))
)
)
(merge_first_row xlsht columns)
)
(progn
(setq row 0)
(foreach lst data
(setq row (1+ row)
col 1
)
(foreach itm lst
(vlax-put-property
xlcls
"Item"
row
col
(vl-princ-to-string itm)
)
(setq col (1+ col))
)
)
)
)
(draw-grid xlapp xlsht)
(setq xlrng (vlax-get-property xlsht 'UsedRange))
(setq xlcols (vlax-get-property xlrng 'Columns))
(vlax-invoke-method xlcols 'AutoFit)
(vlax-invoke-method
xlwbk
'SaveAs
(strcat (getvar "dwgprefix") "List.xls")
-4143
nil
nil
:vlax-false
:vlax-false
1
2
)
(vlax-release-object xlcls)
(vlax-release-object xlsht)
(vlax-release-object xlshts)
(vlax-release-object xlwbk)
(vlax-release-object xlbks)
(vlax-release-object xlapp)
(setq xlapp nil)
(alert "Excel File Was Saved.
Close Excel Manually")
)
)
(gc)
(gc)
(gc)
(princ)
)
(princ "\n===========================\n")
(princ "\n Start with LX to run ...")
(princ "\n===========================\n")
(princ)
~'J'~
干得好！谢谢laa。。
amr公司 不客气
~'J'~
页:
[1]