SSGET-带Promp的块分解
我的目标是让程序分解具有Description属性的属性块，该属性具有字符串“VV？？”，“VB？？”，“VY？？”，“VD？？”，“VG？？”，“VT？？”，“VN？？”，“VP？？”，“V3？？”，“V4？？”。问号是任何非空白字符。下面左边的图片显示了“before”块，after显示了分解后的前一个块以及设置到另一层的部分实体。我不得不手动更改图形，因为我认为不可能提出自动解决方案。但我想提示用户能够选择要更改到某一层的行（在本例中为“FTG Hndwhl”），然后继续下一个符合标准的块。
https://www.cadtutor.net/forum/attachment.php?attachmentid=63590&cid=1&stc=1
以下是迄今为止的代码（改编自之前的ronjonp代码）：
提供的测试图纸不是原生AutoCAD文档，因此它会对您咆哮，并让您意识到这一点。有2个块符合测试图纸中的标准。
请告诉我你认为它需要什么。
格雷格
Test1.DWG 不确定它是否有用，但我经常使用“突发”来放置0层定义的对象，这些对象以前显示了块插入到其插入层上的层的属性。BURST只分解一个级别，而EXPLODE将块内的多段线减少为直线和圆弧。分解甚至分解块内的维度，而爆裂则不会。 我觉得写这个有点脏，但给你。
(defun c:test (/ _getattvalue s)
;; RJP - Simple get attribute value sub .. no error checking
(defun _getattvalue (block tag)
(vl-some
'(lambda (att)
(cond ((eq (strcase tag) (strcase (vla-get-tagstring att))) (vla-get-textstring att)))
)
(vlax-invoke block 'getattributes)
)
)
;; RJP - added (66 . 1) to filter ( attributed blocks )
(cond ((setq s (ssget "_C" '(7.244 2.071) '(16.665 10.003) '((0 . "INSERT") (66 . 1))))
(foreach en (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
(if (and ;; If we have a value, and it does not match the filter then remove item from selection
(setq v (_getattvalue (vlax-ename->vla-object en) "Description"))
;; vl-string-search example ( more legible IMO )
(vl-some '(lambda (x) (wcmatch (strcase v) (strcat "*" x "*")))
'("VV" "VB" "VY" "VD" "VG" "VT" "VN" "VP" "V3" "V4")
)
)
(progn (foreach i (vlax-invoke (vlax-ename->vla-object en) 'explode)
(if (= "AcDbAttributeDefinition" (vla-get-objectname i))
(vl-catch-all-apply 'vla-delete (list i))
(entmod (append (entget (vlax-vla-object->ename i)) '((8 . "NewLayer"))))
)
)
(entdel en)
)
)
)
;; Highlight selection
;; (sssetfirst nil s)
)
)
(princ)
)
(vl-load-com)
好肮脏的心灵永远是一种快乐
英雄联盟
罗恩·琼普，谢谢你（不管脏不脏）！
这很好，但它将整个块更改为新层，而不是保留在其本机层。只有来自块的一些多段线需要转到新图层，并让用户手动拾取它们。
但我想了很多，我有了另一个想法。分解块后，是否可以由“刚分解的块”组成集合，从而用户可以在多段线之间循环，并提示用户将高亮显示的多段线更改为新图层？这可能是一个比手动拾取更好的解决方案。但我不知道这是否可行。
格雷格 有什么想法吗？
格雷格 试试这个。。在我看来，我还是太过手动了，但是。你在不同层上用这些分解的信息做什么？
(defun c:test (/ _getattvalue o s ll ur)
;; RJP - Simple get attribute value sub .. no error checking
(defun _getattvalue (block tag)
(vl-some
'(lambda (att)
(cond ((eq (strcase tag) (strcase (vla-get-tagstring att))) (vla-get-textstring att)))
)
(vlax-invoke block 'getattributes)
)
)
;; RJP - added (66 . 1) to filter ( attributed blocks )
(cond
((setq s (ssget "_C" '(7.244 2.071) '(16.665 10.003) '((0 . "INSERT") (66 . 1))))
(foreach en (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
(if (and ;; If we have a value, and it does not match the filter then remove item from selection
(setq v (_getattvalue (setq o (vlax-ename->vla-object en)) "Description"))
;; vl-string-search example ( more legible IMO )
(vl-some '(lambda (x) (wcmatch (strcase v) (strcat "*" x "*")))
'("VV" "VB" "VY" "VD" "VG" "VT" "VN" "VP" "V3" "V4")
)
)
(progn
(vlax-invoke (vlax-get-acad-object) 'zoomcenter (vlax-get o 'insertionpoint) 1)
(foreach i (vlax-invoke o 'explode)
(if (= "AcDbAttributeDefinition" (vla-get-objectname i))
(vl-catch-all-apply 'vla-delete (list i))
(progn
(vla-put-color i 1)
(vla-update i)
(if
(getpoint "\nPick a point to change red object layer or enter for no change: ")
(entmod (append (entget (vlax-vla-object->ename i)) '((8 . "NewLayer"))))
)
)
)
)
(entdel en)
)
)
)
;; Highlight selection
;; (sssetfirst nil s)
)
)
(princ)
)
我感谢你的帮助！
背景故事：客户想要不同层次的符号，这就是它的来源。符号由块生成。创建dwg时，客户端所需级别的粒度超过了生成数据的程序的能力。因此，我必须制定一个程序，将具有完全相同图形内容的图形转换为符合客户CAD标准的图形。
我希望这有点道理。
格雷格 下面是一个快速示例，通过块内已知长度的对象更改层。。
3
页:
[1]
2