《块属性输出到excel》

langjs · 发表于 2024-3-6 13:46

;;; ===============================================
;;; 《块属性输出到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)
)

yimiyangguang55 · 发表于 2024-3-7 23:18

大师，请教您一个问题，我有一个将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-8 15:58

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:16

本帖最后由 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)
)
)

p-3-ianlcc · 发表于 2024-3-6 14:00

头香，感谢大师的分享
这一定要留存着使用

lxl217114 · 发表于 2024-3-6 14:19

大佬又发新作，非常顶。

zhangcan0515 · 发表于 2024-3-6 14:27

大佬有发福利了，谢谢老师

magicheno · 发表于 2024-3-6 15:44

感谢大佬分享

jkop · 发表于 2024-3-6 19:14

大佬连发，先都用看看再说。

ferious · 发表于 2024-3-7 08:51

鹏程九万里，感谢郎大师！

菜卷鱼 · 发表于 2024-3-7 10:08

输出html格式，也是可以的，后缀改成xls
有些电脑不装微软excel ，装的wps

langjs · 发表于 2024-3-7 10:23

xyp1964 发表于 2024-3-6 20:16
输出csv格式可能更通用：

(if (setq ss (ssget '((0 . "insert") (66 . 1))))

主要是我几个程序是导出去再导回来，就用EXCEL编了

账号		自动登录	找回密码
密码			注册

[源码] 《块属性输出到excel》

评分

点评