gaics 发表于 2020-9-11 22:56
显示“参数类型错误: lselsetp nil”的原因是图纸范围内没有选择到text文本。
(setq ss (ssget "_X" (list ...
大师，能完善下像以前你帮我修改的目录生成器一样指定块，指定属性标记导出表格，导出顺序以图块的位置从左到右从上到下导出。导出的表格保存在CAD文件的位置，楼主的程序导出的表格是存在文档不是很方便查找。
导入也是指定块选择属性图块从左到右，从上到下导入。
以下是大师你以前帮我完善的目录生成器
图纸目录生成器
(defun c:ml (/ blknamezxtag 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
)
看看我也来看看 我也做了一个属性到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)
) langjs 发表于 2022-5-24 16:45
我也做了一个属性到EXCEL 程序，可以试试
;;; ===============================================
lang大师，有没有打算写excel导入到属性块的功能啊？ langjs 发表于 2022-5-24 16:45
我也做了一个属性到EXCEL 程序，可以试试
;;; ===============================================
这正是要找的，
能麻烦大师帮忙再加入属性图框内多行文本中内容的提取吗？如“材料：”“下料尺寸：”“表面处理：”“数量：”这四个后面对应的红色内容一起分别提取到EXCEL吗？ langjs 发表于 2022-5-24 16:45
我也做了一个属性到EXCEL 程序，可以试试
;;; ===============================================
高版本的Excel 怎么改 wzg356 发表于 2020-9-12 10:18
函数：VxGetAtts
功能：获取块中所有属性
函数代码：
大佬，请问下，这个lsp的启动命令是什么呢，刚想测试下，看代码还是没看懂启动命令:handshake
页:
1
[2]