块属性导出导入excel

lwb514 · 发表于 2020-10-1 21:28:17

感谢楼主分享

KO你 · 发表于 2021-12-13 16:15:21

本帖最后由 KO你于 2021-12-13 16:30 编辑

gaics 发表于 2020-9-11 22:56
显示“参数类型错误: lselsetp nil”的原因是图纸范围内没有选择到text文本。
(setq ss (ssget "_X" (list ...

大师，能完善下像以前你帮我修改的目录生成器一样指定块，指定属性标记导出表格，导出顺序以图块的位置从左到右从上到下导出。导出的表格保存在CAD文件的位置，楼主的程序导出的表格是存在文档不是很方便查找。
导入也是指定块选择属性图块从左到右，从上到下导入。
以下是大师你以前帮我完善的目录生成器
图纸目录生成器
(defun c:ml (/             blkname  zxtag       nametag       numtag       shuxing
         ss             sslist file       index0       index       tmp_pt
         XZ_sortlist    s1       s2       s3       s4
         lst0    lst    i       ii       tk       sslist_ptl
         path    drawingname
         )
  (setvar "cmdecho" 0)
  (princ "\n第1步：请选择“子项”属性字...")
  (setq zxtag (multi_select))
  (princ "\n第2步：请选择“图名”属性字...")
  (setq nametag (multi_select))
  (princ "\n第3步：请选择“图号”属性字...")
  (if (setq numtag (choose_att2))
(progn (setq blkname (cdr numtag))
         (setq numtag (car numtag))
)
  )
  (princ "\n第4步：请选择需要生成目录的对象...")
  (setq ss (ssget (list '(0 . "insert") (cons 2 blkname))))
  ;;"blkname"from(multi_select)
  (setq       index0 0
      index  (sslength ss)
      sslist '()
  )
  (repeat index
(setq sslist (cons (ssname ss index0) sslist))
(setq index0 (1+ index0))
  )
  ;;开始构建图元点位表
  (setq       index0 0
      sslist_ptl
      '()
      tmp_pt '()
  )
  (repeat index
(setq tmp_pt
         (cons
         (nth index0 sslist)
         (cons (cdr (assoc 10 (entget (nth index0 sslist)))) tmp_pt)
         )
)
(setq sslist_ptl (cons tmp_pt sslist_ptl))
(setq tmp_pt '())
(setq index0 (1+ index0))
  )
  ;;开始排序
  ;;从左到右从上到下
  (setq       XZ_sortlist
      (vl-sort
         (vl-sort sslist_ptl
                  '(lambda (s1 s2) (> (cadadr s1) (cadadr s2)))
         )
         '(lambda (s3 s4)
            (if (equal (cadadr s3) (cadadr s4) 300)
            (< (caadr s3) (caadr s4))
            )
         )
      )
  )
  (setq i 0)
  (setq lst '())
  (while (< i (length XZ_sortlist))
(setq tk (car (nth i XZ_sortlist)))
(setq shuxing (get_att tk))
(setq lst0 '())
(if       zxtag
   (setq lst0 (cons (str_value zxtag shuxing) lst0))
)
(if       nametag
   (setq lst0 (cons (str_value nametag shuxing) lst0))
)
(if       numtag
   (setq lst0 (cons (cdr (assoc numtag shuxing)) lst0))
)
(setq lst (cons (reverse lst0) lst))
(setq i (+ i 1))
  )
  (setq lst (reverse lst))
  (setq path (getvar 'DWGPREFIX))
  (setq drawingname (vl-filename-base (getvar 'DWGNAME)))
  (setq file (open (strcat path drawingname "图纸目录.txt") "w"))
  (setq i 0)
  (while (< i (length lst))
(write-line
   (vl-string-trim "()" (vl-princ-to-string (nth i lst)))
   file
)
(setq i (+ i 1))
  )
  (close file)
  (princ)
)

(defun get_att (tk)
  (setq obj (vlax-ename->vla-object tk))
  (mapcar '(lambda (att)
         (cons (vla-get-TagString att) (vla-get-TextString att))
         )
      (vlax-invoke obj "GetAttributes")
  )
)

(defun choose_att2 (/ a b)
  (if (setq a (entsel))
(progn (setq b (car (nentselp (cadr a)))) ;图元名
         (if (/= (cdr (assoc 0 (entget b))) "ATTRIB") ;图元属性
         (progn (alert "******必须选择属性字!******")
                  (choose_att)
         )
         (cons (cdr (assoc 2 (entget b)))
               (cdr (assoc 2 (entget (car a))))
         )
         )
)

  )
)

(defun multi_select (/ a b)
  (setq b '())
  (while (setq a (choose_att2))
(setq blkname (cdr a))
(if       b
   (setq b (cons (car a) b))
   (setq b (list (car a)))
)
(princ "请继续选择，如已完成请按空格键或鼠标右键...")
  )
  (reverse b)
)
(defun str_value (tag shuxing / ii value lst)
  (setq ii 0)
  (while (< ii (length tag))
(setq value (cdr (assoc (nth ii tag) shuxing)))
(setq lst (cons value lst))
(setq value (apply 'strcat (reverse lst)))
(setq ii (1+ ii))
  )
  value
)

cwgchen · 发表于 2022-5-23 14:25:46

看看我也来看看

langjs · 发表于 2022-5-24 16:45:55

我也做了一个属性到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)

   (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)
)

AndyWang · 发表于 2022-5-25 10:14:56

langjs 发表于 2022-5-24 16:45
我也做了一个属性到EXCEL 程序，可以试试

;;; ===============================================

lang大师，有没有打算写excel导入到属性块的功能啊？

seamopan · 发表于 2022-5-25 16:39:22

langjs 发表于 2022-5-24 16:45
我也做了一个属性到EXCEL 程序，可以试试

;;; ===============================================

这正是要找的，
能麻烦大师帮忙再加入属性图框内多行文本中内容的提取吗？如“材料：”“下料尺寸：”“表面处理：”“数量：”这四个后面对应的红色内容一起分别提取到EXCEL吗？

书院扫地僧 · 发表于 2023-5-28 17:24:55

langjs 发表于 2022-5-24 16:45
我也做了一个属性到EXCEL 程序，可以试试

;;; ===============================================

高版本的Excel 怎么改

weimeng555 · 发表于 2024-5-5 02:47:34

wzg356 发表于 2020-9-12 10:18
函数：VxGetAtts
功能：获取块中所有属性
函数代码：

大佬，请问下，这个lsp的启动命令是什么呢，刚想测试下，看代码还是没看懂启动命令

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

[提问] 块属性导出导入excel

本帖子中包含更多资源