[CAD插件] 块属性输出到excel

[复制链接]
查看888 | 回复0 | 2024-3-7 16:07:08 | 显示全部楼层 |阅读模式
(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橱柜家具设计3群
回复

使用道具 举报

右侧快捷回复! 回复垃圾贴,封禁帐号!
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则