这是一个可以归类图层的小插件

wuzhenif

从别人那里传来的图，有些还要拷进自己的图里，看着那乱七八糟的图层，真的要吐，像我这样的强迫症，不能忍，真的不能忍，于是有了下面这个插件：
这是一个按照线性，线宽，颜色，类型（文字、直线、多段线、圆、圆弧、填充），对这些图元进行图层归类的小插件，其中先判断是不是非打印层，如果是非打印层是不处理的，这个插件不是每个人都适用，仅作为参考。具体功能看一下后面的演示。
2023/08/21更新：
（一）、下面附件1 图层合并v1.1 优化了一些bug：
1.有的电脑无法加载DOTE线性，所以把加载DOTE线型改为加载CENTER线型，防止出错。
2.有的多段线是没有定义全局宽度的，比如箭头，碰到这种多段线就会出错，并打断程序运行，所以增加了一个错误处理，防止出错中止。
（二）、下面附件2 块中图元改层 v1.0 ，顾名思义，可以修改一个块中所有图元的图层，下面有演示，收一个明经币意思一下，为了以后更大的进步
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

huxu823

2. (defun addlay ()
   
3.   (setq  list1 '(
   
4.     ("S_DETL" 7 "Continuous")
   
5.     ("THIN" 4 "Continuous")
   
6.     ("THICK" 6 "Continuous")
   
7.     ("REINL" 1 "Continuous")
   
8.     ("BEAM" 4 "DASHED")
   
9.     ("HATCH" 254 "Continuous")
   
10.     ("TEXT" 7 "Continuous")
    
11.     ("DIM" 3 "Continuous")
    
12.     ("DOTE" 1 "CENTER")
    
13.          )
    
14.   )
    
15.   (foreach ltype1 '("CENTER" "DASHED")
    
16.     ;;加载线型
    
17.     (if  (= (tblsearch "ltype" ltype1) nil)
    
18.       (command "_.linetype" "l" ltype1 "" "")
    
19.     )
    
20.   )  ;加载线型结束
    
21. 
    
22.   (foreach sobj  list1
    
23.     (setq layname (car sobj))
    
24.     (setq color1 (cadr sobj))
    
25.     (setq lt (caddr sobj))
    
26.     (setq a1 (tblsearch "layer" layname))
    
27.     (if (= a1 nil)
    
28.       (progn
    
29.   (setq lay1 (vla-add layersobj layname))
    
30.   (vla-put-color lay1 color1)
    
31.   (vla-put-linetype lay1 lt)
    
32.       )
    
33.       (prin1)
    
34.     )
    
35.   )
    
36. )  ;end defun
    

(defun addlay ()<br />   (setq  list1 '(<br />     ("S_DETL" 7 "Continuous")<br />     ("THIN" 4 "Continuous")<br />     ("THICK" 6 "Continuous")<br />     ("REINL" 1 "Continuous")<br />     ("BEAM" 4 "DASHED")<br />     ("HATCH" 254 "Continuous")<br />     ("TEXT" 7 "Continuous")<br />     ("DIM" 3 "Continuous")<br />     ("DOTE" 1 "CENTER")<br />          )<br />   )<br />   (foreach ltype1 '("CENTER" "DASHED")<br />     ;;加载线型<br />     (if  (= (tblsearch "ltype" ltype1) nil)<br />       (command "_.linetype" "l" ltype1 "" "")<br />     )<br />   )  ;加载线型结束<br /> <br />   (foreach sobj  list1<br />     (setq layname (car sobj))<br />     (setq color1 (cadr sobj))<br />     (setq lt (caddr sobj))<br />     (setq a1 (tblsearch "layer" layname))<br />     (if (= a1 nil)<br />       (progn<br />   (setq lay1 (vla-add layersobj layname))<br />   (vla-put-color lay1 color1)<br />   (vla-put-linetype lay1 lt)<br />       )<br />       (prin1)<br />     )<br />   )<br /> )  ;end defun<br />

对于创建线型的部分，给创建的图层分别设置默认线宽和指定线宽，要如何修改代码?

wuzhenif

ikias 发表于 2023-8-20 19:16
我用了一下，怎么老是不成功呢

不知道啊，我也只是个菜鸟，可能你处理的东西比较复杂吧，目前还不支持图块的处理，如果你选择的东西里包括图块，可能就不行

wuzhenif

旧友 发表于 2023-8-20 17:45
大佬，您好。这个代码怎么使用啊？麻烦大佬方便的时候指导一下，非常感谢

我也是刚入门的菜鸟，代码复制下来，拷到文本里，把文本后缀改为.lsp，就可以用了

lxl217114

谢谢分享源码

xcmdos

谢谢分享源码

BUBUBA918

非常好的软件

a461346548

感谢分享源码。

czb203

感谢分享源码。

paulpipi

感谢分享源码

cfc

感谢分享，还挺实用的

陨落

你好！这个功能很厉害

wuzhenif

陨落 发表于 2023-8-20 14:56
你好！这个功能很厉害

暂时还不支持图块的处理，还在学习中，努力把块处理完善了就完美了