《块属性输出到excel》
;;; ===============================================;;; 《块属性输出到excel》
;;; 作者：langjs 命令:atoe
;;; ===============================================
(defun c:atoe (/ active-sheet appxls ash cell col default elist ename ent i intcol j loop lst lst1 lst2
msxl-xl24hourclock n na name name0 newbook newitem newsheet nu numrow obj out path relcol relrow rng row
ss ss0 str tlb tlbfile tlbver ty xlcontinuous xlscells xlsworkbooks
) ;加载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
) ; 为选中的范围的实行自动调整宽度
(defun dsx-excel-rangeautofit (active-sheet)
(vlax-invoke-method (vlax-get-property (vlax-get-property (vlax-get-property active-sheet 'usedrange) 'cells)
'columns
) 'autofit
)
) ; 为选中的范围的实行网格线（自加）
(defun dsx-excel-gridline (active-sheet)
(vlax-invoke-method (vlax-get-property (vlax-get-property (vlax-get-property active-sheet 'usedrange) 'cells)
'columns
) 'borderaround xlcontinuous default 1
)
) ; 为指定单元格填入颜色 (dsx-excel-put-cellcolor 1 1 14)
; 将颜色#14填入到单元格(1,a)
(defun dsx-excel-put-cellcolor (row col intcol / rng)
(setq rng (dsx-excel-get-cell ash row col))
(msxl-put-colorindex (msxl-get-interior rng) intcol)
) ; 在活动的工作表中的单个单元格中获取数据; 获取行列范围内的单元格对象
(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)))
)
(defun data2cell (cell numrow col str) ; 写excel
(vlax-put-property cell "item" numrow col (vl-princ-to-string str))
)
(defun celltext (cell nu) ; 把某一行或者列设置成文本各自nu"a:a"
(vlax-put-property (msxl-get-range cell nu) "NumberFormat" (vlax-make-variant "@"))
)
(defun initexcel ()
(dsx-load-typelib-excel)
(setq appxls (vlax-get-or-create-object "excel.application")
xlsworkbooks (vlax-get-property appxls "workbooks")
newbook (vlax-invoke-method xlsworkbooks "add")
newsheet (vlax-get-property newbook "sheets")
newitem (vlax-get-property newsheet "item" 1)
xlscells (vlax-get-property newitem "cells")
ash (msxl-get-activesheet appxls)
)
(vla-put-visible appxls :vlax-true)
)
(defun endexcel ()
(vlax-release-object xlscells)
(vlax-release-object newitem)
(vlax-release-object newsheet)
(vlax-release-object newbook)
(vlax-release-object xlsworkbooks)
(vlax-release-object appxls)
)
(defun #err (s)
(setvar "nomutt" 0)
(if name0
(redraw name0 4)
)
(setq *error* $orr)
)
(setq $orr *error*)
(setq *error* #err)
(vl-load-com)
(setvar "cmdecho" 0) ; 关闭命令响应
(setvar "nomutt" 1)
(princ "\n 属性转EXCEL")
(princ "\n选择属性块:")
(while (not (and
(setq ss0 (ssget ":E:S" (list '(0 . "insert") '(66 . 1))))
(setq name0 (ssname ss0 0))
(setq ent (entget name0))
(setq na (assoc 2 ent))
)
)
(if (= 52 (getvar "errno"))
(vl-exit-with-error "")
)
)
(if ss0
(progn
(redraw name0 3)
(princ "\n框选属性块:")
(setq ss (ssget (list '(0 . "INSERT") na '(66 . 1))))
(if (not ss)
(setq ss ss0)
)
(redraw name0 4)
(setq ss (ssadd name0 ss))
(setq lst '())
(repeat (setq i (sslength ss))
(setq name (ssname ss (setq i (1- i))))
(setq ent (entget name))
(setq ty (cdr (assoc 2 ent)))
(setq ename (entnext name))
(setq loop t)
(setq lst1 '())
(setq lst2 '())
(while (and
ename
loop
)
(setq elist (entget ename))
(if (= (cdr (assoc 0 elist)) "ATTRIB")
(progn
(setq lst1 (cons (cdr (assoc 1 elist)) lst1))
(setq lst2 (cons (cdr (assoc 2 elist)) lst2))
)
(setq loop nil)
)
(setq ename (entnext ename))
)
(setq lst (cons (reverse lst1) lst))
)
(setq lst (cons (reverse lst2) lst))
(initexcel)
(celltext xlscells "B:B")
(setq i 1)
(foreach lst1 lst
(setq j 1)
(foreach n lst1
(data2cell xlscells i j n) ; (dsx-excel-get-cell ash i j)
; (dsx-excel-gridline ash)
(setq j (1+ j))
)
(setq i (1+ i))
)
(dsx-excel-rangeautofit ash)
(dsx-excel-gridline ash)
(setq i 0)
(repeat (length lst2)
(dsx-excel-put-cellcolor 1 (setq i (1+ i))
6
)
)
(endexcel)
)
)
(setvar "nomutt" 0)
(princ)
) 大师，请教您一个问题，我有一个将CAD里面通过xyz坐标将文字导出到excel， excel文字导出到CAD的程序，现在可以从CAD导出，但是目前没法导入。请教大神该如何修改呢。其实最佳的方式是将文件导出到已经打开excel中，然后在excel中修改后再导回CAD中。不知道能否实现呢。
(defun c:EXTCSV (/ ss i f ename text pos)
(setq ss (ssget "X" '((0 . "TEXT,MTEXT"))))
(if ss
(progn
(setq f (open "D:/autocad_text.csv" "w"))
(if f
(progn
(write-line "TextString,X,Y,Z" f)
(setq i -1)
(repeat (sslength ss)
(setq i (1+ i))
(setq ename (ssname ss i))
(setq text (cdr (assoc 1 (entget ename))))
(setq pos (cdr (assoc 10 (entget ename))))
(write-line (strcat text "," (rtos (car pos)) "," (rtos (cadr pos)) "," (rtos (caddr pos))) f)
)
(close f)
(princ "\nText has been exported to D:/autocad_text.csv")
)
(princ "\nFailed to open file for writing.")
)
)
(princ "\nNo text found in the drawing.")
)
(princ)
)
(defun c:IMTCSV (/ f line fields text pos)
(setq f (open "D:/autocad_text.csv" "r"))
(if f
(progn
(read-line f) ; Skip the header line
(while (setq line (read-line f))
(setq fields (strtok line ","))
(setq text (nth 0 fields))
(setq pos (list (atof (nth 1 fields)) (atof (nth 2 fields)) (atof (nth 3 fields))))
(command "TEXT" pos "" "" text)
)
(close f)
(princ "\nText has been imported from D:/autocad_text.csv")
)
(princ "\nFailed to open file for reading.")
)
(princ)
)
yimiyangguang55 发表于 2024-3-7 23:18
大师，请教您一个问题，我有一个将CAD里面通过xyz坐标将文字导出到excel， excel文字导出到CAD的程序，现在 ...
正是慕名来找到您的帖子，
群里一个大神加了一段函数后，可以导出导入了。但是格式不一样，后处理特别码放。现在想请教您，有没有其他函数将导出导入的文字的格式一样。
导入函数加了这个语言，就可以运行了。
(defun STRTOK (str del / pos)
(if (setq pos (vl-string-search del str))
(cons (substr str 1 pos)
(STRTOK (substr str (+ pos 1 (strlen del))) del)
)
(list str)
)
) 本帖最后由 xyp1964 于 2024-3-6 20:17 编辑
输出csv格式可能更通用：
(if (setq ss (ssget '((0 . "insert") (66 . 1))))
(setq lst (mapcar 'xyp-Att2list (xyp-Ss2List ss))
lst (mapcar '(lambda (x) (mapcar 'cdr x)) lst)
lst (xyp-DelSame (apply 'append lst))
aa (xyp-List2Csv lst)
)
)
头香，感谢大师的分享
这一定要留存着使用 大佬又发新作，非常顶。 大佬 有发福利了，谢谢老师 感谢大佬分享 大佬连发，先都用看看再说。 鹏程九万里，感谢郎大师！ 输出html格式，也是可以的，后缀改成xls
有些电脑不装微软excel ，装的wps xyp1964 发表于 2024-3-6 20:16
输出csv格式可能更通用：
(if (setq ss (ssget '((0 . "insert") (66 . 1))))
主要是我几个程序是导出去再导回来，就用EXCEL编了