这是一个可以归类图层的小插件
本帖最后由 wuzhenif 于 2023-8-26 12:04 编辑从别人那里传来的图，有些还要拷进自己的图里，看着那乱七八糟的图层，真的要吐:dizzy:，像我这样的强迫症，不能忍，真的不能忍，于是有了下面这个插件：
这是一个按照线性，线宽，颜色，类型（文字、直线、多段线、圆、圆弧、填充），对这些图元进行图层归类的小插件，其中先判断是不是非打印层，如果是非打印层是不处理的，这个插件不是每个人都适用，仅作为参考。具体功能看一下后面的演示。
2023/08/21更新：
（一）、下面附件1 图层合并v1.1 优化了一些bug：
1.有的电脑无法加载DOTE线性，所以把加载DOTE线型改为加载CENTER线型，防止出错。
2.有的多段线是没有定义全局宽度的，比如箭头，碰到这种多段线就会出错，并打断程序运行，所以增加了一个错误处理，防止出错中止。
（二）、下面附件2 块中图元改层 v1.0 ，顾名思义，可以修改一个块中所有图元的图层，下面有演示，收一个明经币意思一下，为了以后更大的进步:lol
2023/08/26重磅更新，图层合并v1.2，详附件3：
1）、增加块批量处理，程序更通用了
2）、优化一些bug
以下是源代码，无偿奉献给大家：
;;以下为主程序
;;获取选择集，并按条件替换图层
(defun c:tchb (/ ss i objname xobj type1)
(setvar "cmdecho" 0) ; 关闭命令响应
(vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
(setq acadobj (vlax-get-acad-object))
(setq dwgobj (vla-get-ActiveDocument acadobj))
(setq mspace (vla-get-ModelSpace dwgobj))
(setq layersobj (vla-get-layers dwgobj))
;取得当前图形文件中的图层集合对象
(setq ss (ssget)) ;获取选集
(addlay) ;新建图层
(repeat (setq i (sslength ss))
(setq objname (ssname ss (setq i (1- i))))
;ssname,选择集中的第一个元素的序号为零 (0)。如果成功，返回图元名
(setq xobj (vlax-ename->vla-object objname))
(judge-Plottable xobj) ;子程序，判断是否为非打印层
(if (= Plot-result :vlax-false)
(prin1)
(classify-xobj xobj) ;子程序，对单个图元进行归类
) ;end if
) ;end repeat
(command "_.purge" "la" "" "n")
(prin1)
) ;end defun
(princ "请输入命令:TCHB ***作者：魂之彼岸***")
;;以下为建立新图层到layersobj中的子程序
(defun addlay ()
(setq list1 '(
("S_DETL" 7 "Continuous")
("THIN" 4 "Continuous")
("THICK" 6 "Continuous")
("REINL" 1 "Continuous")
("BEAM" 4 "DASHED")
("HATCH" 254 "Continuous")
("TEXT" 7 "CONTINUOUS")
("DIM" 3 "CONTINUOUS")
("DOTE" 1 "DOTE")
)
)
(foreach ltype1 '("DOTE" "DASHED")
;;加载线型
(if (= (tblsearch "ltype" ltype1) nil)
(command "_.linetype" "l" ltype1 "" "")
)
) ;加载线型结束
(foreach sobj list1
(setq layname (car sobj))
(setq color1 (cadr sobj))
(setq lt (caddr sobj))
(setq a1 (tblsearch "layer" layname))
(if (= a1 nil)
(progn
(setq lay1 (vla-add layersobj layname))
(vla-put-color lay1 color1)
(vla-put-linetype lay1 lt)
)
(prin1)
)
)
) ;end defun
;;;以下为确定对象是否具有指定特性
;;;(vlax-property-available-p xobj 'ConstantWidth)
;;;以下取得对象的AutoCAD图元类别名称
;;;(vla-get-ObjectName xobj)
;;;以下获取对象的线型
;;;(vla-get-Linetype xobj)
;;以下获取对象真实线型,并按线型转换图层
(defun zhixian (xobj)
(real-linetype xobj)
(cond
((member linetype1
'("DOTE" "ACAD_ISO04W100"
"CENTER" "CENTER2" "CENTERX2"
"DASHDOT" "DASHDOT2" "DASHDOTX2"
)
)
(progn
(vla-put-Layer xobj "DOTE")
(setq color4 (vla-get-Color xobj))
(if (/= color4 256)
(vla-put-Color xobj 256)
(prin1)
)
)
)
((member linetype1
'("ACAD_ISO02W100" "ACAD_ISO03W100" "DASHED"
"DASHED2" "DASHEDX2" "HIDDEN"
"HIDDEN2" "HIDDENX2"
)
)
(vla-put-Layer xobj "BEAM")
)
((= linetype1 "CONTINUOUS")
(vla-put-Layer xobj "THIN")
)
)
) ;end defun
;;以下得出图元的真实颜色（数字）
(defun realcolor (xobj)
(setq co (vla-get-Color xobj)) ;获得图元属性列表中的color值
(cond
((= co 256)
(progn
(setq layername (vla-get-Layer xobj)) ;获得图元所在图层的名称
(setq lalist (tblsearch "layer" layername))
;查找图层列表中名为layername图层的属性点对列表
(setq color2 (cdr (assoc 62 lalist))) ;获得图层的颜色数字
)
)
((/= co 256)
(setq color2 co)
)
)
) ;end defun
;;以下为获取多段线图元全局宽度,并按线宽和颜色归类
(defun duoduanxian (xobj)
(realcolor xobj)
(setq plwidth (vla-get-ConstantWidth xobj))
(cond
((<= plwidth 5.0) (vla-put-Layer xobj "S_DETL"))
((and (> plwidth 5.0) (= color2 1))
(vla-put-Layer xobj "REINL")
)
(t (vla-put-Layer xobj "THICK"))
)
) ;end defun
;;以下为取出所有图层列表的子程序
(defun getlayers (dwgobj)
(setq laylist nil)
(setq layersobj (vla-get-layers dwgobj))
;取得当前图形文件中的图层集合对象
(vlax-for sobj layersobj
(setq layname (vla-get-name sobj))
(setq laylist (cons layname laylist))
)
(setq laylist (acad_strlsort laylist))
(prin1 laylist)
)
;;以下得出图元的真实线型
(defun real-linetype (xobj)
(setq rlt (vla-get-Linetype xobj)) ;获得图元属性列表中的linetype值
(cond
((= rlt "BYLAYER")
(progn
(setq layername (vla-get-Layer xobj)) ;获得图元所在图层的名称
(setq ltlist (tblsearch "layer" layername))
;查找图层列表中名为layername图层的属性点对列表
(setq linetype1 (cdr (assoc 6 ltlist))) ;获得图层的线型
)
)
((/= rlt "BYLAYER")
(setq linetype1 rlt)
)
)
)
;;以下子程序判断图元所在图层是否非打印
(defun judge-Plottable (xobj)
(setq layername (vla-get-Layer xobj)) ;获得图元所在图层的名称
(setq layid (tblobjname "layer" layername))
;返回指定符号表(layer)其中某个条目(layername)的图元名（AutoLISP 类型的）
(setq layidx (vlax-ename->vla-object layid))
;这是关键，将 AutoLISP 类型的对象名转换为 VLA 对象
(setq Plot-result (vla-get-Plottable layidx)) ;判断图层是否可以打印
(vlax-dump-object layidx) ;列出对象特性
)
;;以下子程序对单个图元进行归类
(defun classify-xobj (xobj)
(setq type1 (vla-get-ObjectName xobj))
(cond
;;转角标注，对齐标注
((member type1
'("AcDbRotatedDimension" "AcDbAlignedDimension")
)
(progn
(vla-put-Layer xobj "DIM")
(setq color3 (vla-get-Color xobj))
(if (/= color3 256)
(vla-put-Color xobj 256)
(prin1)
)
)
)
;;单行文字和多行文字
((member type1 '("AcDbText" "AcDbMText"))
;搜索表中是否包含某表达式，并从该表达式的第一次出现处返回表的其余部分,返回值不为空，就表示判断式成立，就会执行后面的函数
(vla-put-Layer xobj "TEXT")
)
;;填充
((= type1 "AcDbHatch")
(vla-put-Layer xobj "HATCH")
)
;;多段线部分
;多段线分粗细，细的归入S_DETL,粗的按照颜色归类，红色归入REINL，其他归入THICK
((= type1 "AcDbPolyline")
(duoduanxian xobj)
)
;;直线，分实线，虚线，点划线
((= type1 "AcDbLine")
(zhixian xobj)
)
;;圆弧
((= type1 "AcDbArc")
(vla-put-Layer xobj "S_DETL")
)
;;圆
((= type1 "AcDbCircle")
(vla-put-Layer xobj "S_DETL")
)
(t
(princ)
)
) ;end cont
) ;end defun
ikias 发表于 2023-8-20 19:16
我用了一下，怎么老是不成功呢
不知道啊，我也只是个菜鸟，可能你处理的东西比较复杂吧，目前还不支持图块的处理，如果你选择的东西里包括图块，可能就不行 旧友 发表于 2023-8-20 17:45
大佬，您好。这个代码怎么使用啊？麻烦大佬方便的时候指导一下，非常感谢
我也是刚入门的菜鸟:L，代码复制下来，拷到文本里，把文本后缀改为.lsp，就可以用了 〆看_淡点 发表于 2023-8-21 17:22
要价格对话框设置一下就好了， 标注 DIM。文字TXT。红色0 这样启用和不启用。、
很好的建议 谢谢分享源码 谢谢分享源码 非常好的软件 感谢分享源码。
感谢分享源码。 感谢分享源码:lol 感谢分享，还挺实用的 你好！这个功能很厉害 陨落 发表于 2023-8-20 14:56
你好！这个功能很厉害
暂时还不支持图块的处理，还在学习中，努力把块处理完善了就完美了