求助：提取文本中内容填入到对应于统计表中
下面这程序能正常统计出属性图框中的内容并列表输出，在论坛找了几天没有找到解决的方法；求助大佬们怎么修改程序后能提取图框内文本中对应的内容也统计到表中；
(defun c:mn(/ blkname d1 d2 d3 d4 d5 d6 d7 d8 d9 drawingname file hj h-txt i ii index index0 lst lst0 dwgnotag nametag
path pt1 pt2 pt3 px pxx s1 s2 s3 s4 shuxing ss sslist sslist_ptl tk tmp_pt txt-str XZ_sortlist numtag matltag wxcctag qtytag)
(setvar "cmdecho" 0)
(princ "\n>>>>>请选择“物料编码”属性字...")
(setq numtag (multi_select))
(princ "\n>>>>>选择“图纸编号”属性字...")
(setq dwgnotag (multi_select))
(princ "\n>>>>>选择“零部件名称号”属性字...")
(setq nametag (multi_select))
(princ "\n>>>>>选择“材料名称”属性字...")
(setq matltag (multi_select))
(princ "\n>>>>>选择“下料尺寸”属性字...")
(setq wxcctag (multi_select))
(princ "\n>>>>>选择“数量”属性字...")
(setq qtytag (multi_select))
;(setq blkname (cdr dwgnotag))
; (setq dwgnotag (car dwgnotag))
(princ "\n>>>>>：请选择需要生成目录的对象...")
(setq ss (ssget (list '(0 . "insert") (cons 2 (strcat "`" 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 '())
(ifnumtag
(setq lst0 (cons (str_value numtag shuxing) lst0)) (setq lst0 (cons "" lst0))
)
(ifdwgnotag
(setq lst0 (cons (str_value dwgnotag shuxing) lst0)) (setq lst0 (cons "" lst0))
)
(ifnametag
(setq lst0 (cons (str_value nametag shuxing) lst0)) (setq lst0 (cons "" lst0))
)
(ifmatltag
(setq lst0 (cons (str_value matltag shuxing) lst0)) (setq lst0 (cons "" lst0))
)
(ifwxcctag
(setq lst0 (cons (str_value wxcctag shuxing) lst0)) (setq lst0 (cons "" lst0))
)
(ifqtytag
(setq lst0 (cons (str_value qtytag shuxing) lst0)) (setq lst0 (cons "" 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 h-txt 15 d1 (* 3 h-txt) d2 (* 14 h-txt) d3 (* 22 h-txt) d4 (* 20 h-txt) d5 (* 13 h-txt) d6 (* 13 h-txt) d7 (* 10 h-txt) d8 (* 5 h-txt) d9 (* 10 h-txt) hj (* 3 h-txt)) ;;;;设定字高，间隔尺寸
(setq px (getpoint"\n表格基点:") pxx (polar px(* 0 pi) h-txt))
(command ;"text" "j" "ml" "non" pxx h-txt 0 "序号"
"text" "j" "ml" "non" (polar pxx (* 1 pi) h-txt) h-txt 0 "序号"
"text" "j" "ml" "non" (polar pxx (* 0 pi) d1) h-txt 0 "物料编码"
"text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2)) h-txt 0 "图纸编号"
"text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2 d3)) h-txt 0 "零部件名称"
"text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2 d3 d4)) h-txt 0 "材料"
"text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2 d3 d4 d5)) h-txt 0 "下料尺寸"
"text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2 d3 d4 d5 d6)) h-txt 0 "表面处理"
"text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7)) h-txt 0 "数量"
"text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7 d8)) h-txt 0 "备注"
)
(command "line" "non" (setq pt1 (polar px (* 0.5 pi) (* 0.5 hj))) "non" (setq pt2 (polar px (* 1.5 pi) (* (+ 0.5 (length lst)) hj))) ""
"line" "non" (polar pt1 (* 0 pi) d1) "non" (polar pt2 (* 0 pi) d1) ""
"line" "non" (polar pt1 (* 0 pi) (+ d1 d2)) "non" (polar pt2 (* 0 pi) (+ d1 d2)) ""
"line" "non" (polar pt1 (* 0 pi) (+ d1 d2 d3)) "non" (polar pt2 (* 0 pi) (+ d1 d2 d3)) ""
"line" "non" (polar pt1 (* 0 pi) (+ d1 d2 d3 d4)) "non" (polar pt2 (* 0 pi) (+ d1 d2 d3 d4)) ""
"line" "non" (polar pt1 (* 0 pi) (+ d1 d2 d3 d4 d5)) "non" (polar pt2 (* 0 pi) (+ d1 d2 d3 d4 d5)) ""
"line" "non" (polar pt1 (* 0 pi) (+ d1 d2 d3 d4 d5 d6)) "non" (polar pt2 (* 0 pi) (+ d1 d2 d3 d4 d5 d6)) ""
"line" "non" (polar pt1 (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7)) "non" (polar pt2 (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7)) ""
"line" "non" (polar pt1 (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7 d8)) "non" (polar pt2 (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7 d8)) ""
"line" "non" (polar pt1 (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7 d8 d9)) "non" (polar pt2 (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7 d8 d9)) ""
"line" "non" pt1 "non" (polar pt1 (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7 d8 d9)) ""
)
(setq px (polar px (* 1.5 pi) hj) pxx (polar px(* 0 pi) h-txt))
(setq i 0)
(while (< i (length lst))
;(write-line
;(vl-string-trim "()" (vl-princ-to-string (nth i lst)))
;file
;)
(setq txt-str (nth i lst))
(command "line" "non" (setq pt1 (polar px (* 0.5 pi) (* 0.5 hj))) "non" (setq pt3 (polar pt1 (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7 d8 d9))) ""
)
(command "text" "j" "ml" "non" pxx h-txt 0 (itoa (+ i 1))
)
(command "text" "j" "ml" "non" (polar pxx (* 0 pi) d1) h-txt 0 (car txt-str)
)
(command "text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2)) h-txt 0 (cadr txt-str)
)
(command "text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2 d3)) h-txt 0 (caddr txt-str)
)
(command "text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2 d3 d4)) h-txt 0 (cadddr txt-str)
)
(command "text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2 d3 d4 d5)) h-txt 0 (nth 4 txt-str)
)
(command "text" "j" "ml" "non" (polar pxx (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7)) h-txt 0 (nth 5 txt-str)
)
(setq px (polar px (* 1.5 pi) hj)pxx (polar px(* 0 pi) h-txt))
(setq i (+ i 1))
)
;while
(command "line" "non" (setq pt1 (polar px (* 0.5 pi) (* 0.5 hj))) "non" (setq pt3 (polar pt1 (* 0 pi) (+ d1 d2 d3 d4 d5 d6 d7 d8 d9))) ""
)
; (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))
(ifb
(setq b (cons (car a) b))
(setq b (list (car a)))
)
(princ "请继续选择，如已完成请按空格键或鼠标右键...")
)
(reverse b) )
(vl-load-com)(defun str_value (tag shuxing / ii value lst)
(setq ii 0)
(while (< ii (length tag))
(setq value (cdr (assoc (nth ii tag) shuxing)))
(if (= 0 ii) (setq lst (cons value lst)) (setq lst (cons (strcat "-" value) lst)))
(setq value (apply 'strcat (reverse lst)))
(setq ii (1+ ii))
)
value
)
本帖最后由 vitalgg 于 2022-5-6 14:08 编辑
https://atlisp.cn/stable/at-lab/@lab-summary-data.mp4
安装 @lisp ，及 @实验室 即可运行视频中的程序。
(defun @lab:summary-data (/ tbl-summary get-data)
(@:help (strcat "汇总图框及图框内文本信息\n形成表格"))
(defun get-data (ent / data box mt)
(if ent
(progn
(setq data (block:get-attributes ent))
(setq box (entity:getbox ent 0))
(@:cmd "zoom" "w" (car box)(cadr box))
(setq mt (pickset:to-list
(ssget "w" (car box)(cadr box)
'((0 . "mtext")))))
(if mt
(progn
(setq data-mt
(mapcar 'car
(vl-remove-if '(lambda(x)(cdr x))
(apply 'append
(mapcar '(lambda(x)
(text:parse-mtext
(text:get-mtext x)))
mt)))))
(foreach
txt data-mt
(foreach handle '("材料""下料尺寸""表面处理""数量")
(if (setq res (member handle
(mapcar '(lambda(x)
(vl-string-trim " " x))
(string:parse-by-lst txt '("、""：""；")))))
(setq data (cons (cons handle
(cadr res))
data))))))
)
data
)))
(setq mapsheet (car (entsel)))
(setq ss-tk (ssget "x" (list '(0 . "insert")
(assoc 2 (entget mapsheet)))))
(setq tbl-data (mapcar 'get-data (pickset:to-list ss-tk)))
(setq tbl-header '("物料编码" "图纸编号" "单元名称/零部件名称" "材料""下料尺寸""表面处理""数量" "备注"))
(setq tbl-data (mapcar '(lambda(x / data)
(foreach hd tbl-header
(if (assoc hd x)
(setq data (cons (cdr (assoc hd x)) data))
(setq data (cons "" data)))
)
(reverse data))
tbl-data))
(table:make (getpoint "请输入表格插入位置:") "表格" tbl-header (reverse tbl-data))
)
本帖最后由 vitalgg 于 2022-5-5 19:19 编辑
seamopan 发表于 2022-5-5 16:45
最好是图框属性里的内容用点选，这样可以有更好的通用性，然后每张图纸图框内的文本提取内容能与每张图纸属 ...
开始点一个图框，会按这个图框块名选中所有图框，然后分析每个图框内的多行文本，取出需要的字符串。与块属性一起组成表格数据。
最后汇总写表格。
视频已更新。
https://atlisp.cn/stable/at-lab/@lab-summary-data.mp4
需要注意的是，所有图框必须是显示在屏幕窗口中。不在窗口中的多行文本不会被程序选中，读不出数据。
(@:cmd "zoom" "w" (car box)(cadr box))
代码中已加入自动缩放。
seamopan 发表于 2022-5-5 21:39
很感谢您的修改，能保持原程序中属性图框点选吗？(原程序点选时每个属性项可以根据不同情况加入子项并入 ...
(setq tbl-header '("物料编码" "图纸编号" "单元名称/零部件名称" "材料""下料尺寸""表面处理""数量" "备注"))
在上面加入你要生成表的属性名。
只生成部分图框：把那个（ssget "x" ...) 中的 "X" 去了就可以框选需要的图框了。
设计好的话，点选是不需要的。
可以继续优化。
的确，指定位置指定格式的字符串，可以把需要的信息提取出来。 mikewolf2k 发表于 2022-5-5 09:21
的确，指定位置指定格式的字符串，可以把需要的信息提取出来。
能否麻烦您帮忙修改下啊;P e2002 发表于 2022-5-5 09:12
设计好的话，点选是不需要的。
可以继续优化。
大佬能帮忙优化下吗？程序前面的还是保持点选，就给多行文字中提取对应内容加进来就可以（可以不用点选），支付酬劳也行 vitalgg 发表于 2022-5-5 14:42
安装 @lisp ，及 @实验室 即可运行视频中的程序。
厉害 我上面说的“设计”的含义，主要是指：这些MTEXT中的特定数据，为什么要用 MTEXT来写呢？你不如也做成 Arrtib，然后就能自动提取。提取可以直使用 Table对象。 赞同。对于有特殊意义的文本，尽可能设置唯一的标识，以免更其它无关的文本混淆，既排除干扰又加快速度。当然未必一定要属性，放在特定的层、颜色等都可以，只要符合条件的文本有且只有那些文本即可。 最好是图框属性里的内容用点选，这样可以有更好的通用性，然后每张图纸图框内的文本提取内容能与每张图纸属性对应上就很完美了