[原创]一个图层工具
本帖最后由 langjs 于 2014-5-7 14:14 编辑单位有好多ＣＡＤ的老图，没有按图层绘制比较乱，这个小程序作用是：新建几个标准图层，并把图纸中的图元按照不同类别归到不同图层中去。水平有限，程序写的有些臃肿，有需要的可以下载下来参考使用。
有好多人不明白这个程序是干啥的，我再解释一下吧：比如说，我们单位有好多N年前绘制的dwg格式的图纸，由于当年的绘图员制图不规范，把所有尺寸，线，圆，文字，虚线，中心线都绘制到0层了没有按照图层分类。现在这些图纸还要使用，看着不爽，所以就编写了这个小程序，目的是：执行这个程序，程序自动新建几个标准图层，然后自动把图纸里的尺寸，线，圆，文字，虚线，中心线按照类别规整到各自的标准图层里边去，颜色随层。比如文字就到文字图层里边去了，这样就规范了。后来做了个批量处理工具，我就一下子把单位的几千张图纸都处理好了。
网友让我贴图，实在贴不出来图啊
;;; =================================================================
;;; 图层工具（建一个标准图层，并把图纸中的图元归类到不同图层中去）
;;; 作者：langjs 命令：tcl 2011年1月24日
;;; =================================================================
(defun c:gl (/ chk_lay col ent ent1 i lay layer_info layers linetype lst lt ly_info ly_infos name snap ss ss1 ss2 ss3 ss4 ss5 ss6
ssguol1 ssguol2 ssguol3 ssguol4 tmplist xianxing
) ; 一次性建立多个层
(defun tcl-1 (/ chk_lay col lay lst lt)
(defun mklacolt (lay col lt / chk_lay)
(if (= (tblsearch "layer" lay) nil)
(command "layer" "new" lay "c" col lay "lt" lt lay "")
)
)
(setvar "cmdecho" 0)
(foreach lt '("CENTER" "HIDDEN"
"DASHED" "phantom"
)
(if (= (tblsearch "ltype" lt) nil)
(command "_linetype" "l" lt "" "")
)
)
(foreach lst '(("剖面线层" 40
"CONTINUOUS"
)
("0" 7
"Continuous"
)
("1轮廓实线层" 7
"Continuous"
)
("2细线层" 4
"Continuous"
)
("3中心线层" 1
"CENTER"
)
("4虚线层" 6
"DASHED"
)
("5剖面线层" 2
"Continuous"
)
("6文字层 " 3
"CONTINUOUS"
)
("7标注层" 4
"CONTINUOUS"
)
("8符号标注层" 31
"CONTINUOUS"
)
("9双点划线层" 6
"PHANTOM"
)
("排图层 " 5
"CONTINUOUS"
)
("图框层 " 7
"CONTINUOUS"
)
("消隐层 " -5
"CONTINUOUS"
)
)
(mklacolt (car lst) (cadr lst) (caddr lst))
)
(princ)
)
(defun tcl-2 (ss / ent ent1 i name ss1 ss2 ss3 ss4 ssguol1 ssguol2 ssguol3 ssguol4)
(setq ss1 (ssadd)
ss2 (ssadd)
ss3 (ssadd)
ss4 (ssadd)
) ; 下面程序设置过滤虚线条件
(setq ssguol1 '("ACAD_ISO03W100" "ACAD_ISO02W100"
"DASHED" "DASHED2"
"DASHEDX2" "HIDDEN"
"HIDDEN2" "HIDDENX2"
)
) ; 下面程序将虚线图层加入虚线过滤条件
(setq ssguol1 (append
ssguol1
(tt-01 "ACAD_ISO03W100")
(tt-01 "ACAD_ISO02W100")
(tt-01 "DASHED")
(tt-01 "DASHED2")
(tt-01 "DASHEDX2")
(tt-01 "HIDDEN")
(tt-01 "HIDDEN2")
(tt-01 "HIDDENX2")
)
) ; 下面程序将选择集中随层的虚线图层中的线加入选择集
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (and
(member (cdr (assoc 8 ent1)) ssguol1)
(/= (cdr (assoc 0 ent1)) "INSERT")
(= (assoc 6 ent1) nil)
)
(setq ss1 (ssadd ent ss1))
)
(setq i (+ 1 i))
) ; 下面程序将选择集中其他层的虚线图元加入选择集
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (member (cdr (assoc 6 ent1)) ssguol1)
(setq ss1 (ssadd ent ss1))
)
(setq i (+ 1 i))
) ; 下面程序设置中心线过滤条件
(setq ssguol2 '("ACAD_ISO04W100" "ACAD_ISO08W100"
"ACAD_ISO10W100" "CENTER"
"CENTER2" "CENTERX2"
"DASHDOT" "DASHDOTX2"
"G" "J"
"ZX"
)
) ; 下面程序将中心线图层加入过滤条件
(setq ssguol2 (append
ssguol2
(tt-01 "ACAD_ISO04W100")
(tt-01 "ACAD_ISO08W100")
(tt-01 "ACAD_ISO10W100")
(tt-01 "CENTER")
(tt-01 "CENTER2")
(tt-01 "CENTERX2")
(tt-01 "DASHDOT")
(tt-01 "DASHDOTX2")
(tt-01 "G")
(tt-01 "J")
(tt-01 "ZX")
)
) ; 下面程序将选择集中随层的中心线图层中的线加入选择集
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (and
(member (cdr (assoc 8 ent1)) ssguol2)
(/= (cdr (assoc 0 ent1)) "INSERT")
(= (assoc 6 ent1) nil)
)
(setq ss2 (ssadd ent ss2))
)
(setq i (+ 1 i))
) ; 下面程序将选择集中其他层的中心线图元加入选择集
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (member (cdr (assoc 6 ent1)) ssguol2)
(setq ss2 (ssadd ent ss2))
)
(setq i (+ 1 i))
) ; 下面程序设置双点划线过滤条件
(setq ssguol3 '("ACAD_ISO05W100" "ACAD_ISO12W100"
"DIVIDE" "DIVIDE2"
"DIVIDEX2" "PHANTOM"
"PHANTOM2" "PHANTOMX2"
"SD"
)
) ; 下面程序将双点划线图层加入过滤条件
(setq ssguol3 (append
ssguol3
(tt-01 "ACAD_ISO05W100")
(tt-01 "ACAD_ISO12W100")
(tt-01 "DIVIDE")
(tt-01 "DIVIDE2")
(tt-01 "DIVIDEX2")
(tt-01 "PHANTOM")
(tt-01 "PHANTOM2")
(tt-01 "PHANTOMX2")
(tt-01 "SD")
)
) ; 下面程序将选择集中随层的双点划线图层中的线加入选择集
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (and
(member (cdr (assoc 8 ent1)) ssguol3)
(/= (cdr (assoc 0 ent1)) "INSERT")
(= (assoc 6 ent1) nil)
)
(setq ss3 (ssadd ent ss3))
)
(setq i (+ 1 i))
) ; 下面程序将选择集中其他层的双点划线图元加入选择集
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (member (cdr (assoc 6 ent1)) ssguol3)
(setq ss3 (ssadd ent ss3))
)
(setq i (+ 1 i))
)
(repeat (setq i (sslength ss))
(setq name (ssname ss (setq i (1- i))))
(setq ss4 (ssadd name ss4))
)
(setq ssguol4 (append
ssguol1
ssguol2
ssguol3
)
)
(setq i 0)
(while (< i (sslength ss)) ; 过滤
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (and
(member (cdr (assoc 8 ent1)) ssguol4)
(/= (cdr (assoc 0 ent1)) "INSERT")
(= (assoc 6 ent1) nil)
)
(setq ss4 (ssdel ent ss4))
)
(setq i (+ 1 i))
) ; 过滤
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (member (cdr (assoc 6 ent1)) ssguol4)
(setq ss4 (ssdel ent ss4))
)
(setq i (+ 1 i))
)
(if (/= (sslength ss1) 0)
(command "_.change" ss1 "" "p" "la" "4虚线层" "C" "ByLayer" "")
)
(if (/= (sslength ss2) 0)
(command "_.change" ss2 "" "p" "la" "3中心线层" "C" "ByLayer" "")
)
(if (/= (sslength ss3) 0)
(command "_.change" ss3 "" "p" "la" "9双点划线层" "C" "ByLayer" "")
)
(if (/= (sslength ss4) 0)
(command "_.change" ss4 "" "p" "la" "0" "C" "ByLayer" "")
)
) ; =================================================================
; 获取包含指定线型的图层
(defun tt-01 (xianxing / layers)
(setq layers '())
(setq layers (get_layer_linetype xianxing)) ; 获取包含指定线型的图层
layers
)
(defun get_layer (/ layer_info layers) ; 返回当前图纸中图层信息
(setq layer_info (tblnext "layer" t))
(while (/= layer_info nil)
(setq layers (append
layers
(list layer_info)
)
)
(setq layer_info (tblnext "layer"))
)
layers
)
(defun get_layer_linetype (linetype / ly_info ly_infos tmplist) ; 提取包含指定线型的图层
(setq ly_infos (get_layer))
(foreach ly_info ly_infos
(if (= linetype (substr (cdr (assoc 6 ly_info)) 1 (strlen linetype)))
(setq tmplist (append
tmplist
(list (cdr (assoc 2 ly_info)))
)
)
)
)
tmplist
)
(vl-load-com)
(setvar "cmdecho" 0) ; 关闭命令响应
(if (setq ss (ssget '((0 . "TEXT,MTEXT,DIMENSION,POINT,HATCH,PLINE,LWPOLYLINE,LINE,ARC,CIRCLE,SPLINE,ELLIPSE"))))
(progn
(command ".UNDO" "BE") ; 设置undo起点
(setq snap (getvar "osmode")) ; 关闭捕捉
(setvar "osmode" 0) ; (setq ss (ssget))
(command "_.purge" "la" "" "n")
(tcl-1)
(setq ss1 (ssadd)
ss2 (ssadd)
ss3 (ssadd)
ss4 (ssadd)
ss5 (ssadd)
ss6 (ssadd)
)
(repeat (setq i (sslength ss))
(setq name (ssname ss (setq i (1- i))))
(setq ent (entget name)) ; (princ "\n====")
; (princ ent)
(setq type (cdr (assoc 0 ent)))
(cond
((= type "DIMENSION")
(setq ss1 (ssadd name ss1))
)
((member type '("TEXT" "MTEXT"))
(setq ss2 (ssadd name ss2))
)
((= type "POINT")
(setq ss3 (ssadd name ss3))
)
((= type "HATCH")
(setq ss4 (ssadd name ss4))
)
((member type '("PLINE" "LWPOLYLINE"))
(setq ss5 (ssadd name ss5))
)
((member type '("LINE" "ARC"
"CIRCLE" "SPLINE"
"ELLIPSE"
)
)
(setq ss6 (ssadd name ss6))
)
(t
(princ)
)
)
) ; (princ "\n====")
;(princ (sslength ss6))
(if (/= (sslength ss1) 0)
(command "_.change" ss1 "" "p" "la" "7标注层" "C" "ByLayer" "")
)
(repeat (setq i (sslength ss1))
(vlax-put-property (vlax-ename->vla-object (ssname ss1 (setq i (1- i)))) "textcolor" 3)
)
(if (/= (sslength ss2) 0)
(command "_.change" ss2 "" "p" "la" "6文字层" "C" "ByLayer" "")
)
(if (/= (sslength ss3) 0)
(command "_.erase" ss3 "")
)
(if (/= (sslength ss4) 0)
(command "_.change" ss4 "" "p" "la" "5剖面线层" "C" "ByLayer" "")
)
(if (/= (sslength ss5) 0)
(command "_.change" ss5 "" "p" "la" "1轮廓实线层" "C" "ByLayer" "")
)
(if (/= (sslength ss6) 0)
(tcl-2 ss6)
)
(command "-layer" "c" 7 "0" "")
(command "_.purge" "la" "" "n")
(tcl-1)
(princ "\n已将图元规整到标准图层。")
(setvar "osmode" snap) ; 恢复捕捉
(command ".UNDO" "E") ; 设置undo终点
)
(princ "\n没有找到要规整的图元。")
)
(princ)
)
感谢楼主。
有几个问题能否帮忙看下：
1，标注引线未增加进去；
2，如何将一份外界图纸，按照自己的图层规则，一次性全部一键规整。比如原图图层名中含有某些字样如TEXT全部归到指定标准图层，含有螺丝，fasten字眼全部归到紧固件层，含有虚线，dash,hidden等字眼全部归到虚线层等等。
3，全部规整后，再执行删除无对象图层，或者检测未转化彻底有残余的图层，然后再根据2中自行增加字眼，再次规整，直至全部达到标准图层。
4，用其他插件插入的块中，比如螺钉，如何也可以实现图层规整，并删除多余图层？
langjs 发表于 2011-2-20 23:35
你需要什么样功能不太了解，加我QQ细谈，59509100，可以帮你改一下符合你的要求
有时候，别人的图纸过来，有时候，不要把别人的图层变成一个图层（灰掉），其中中心线层还是保留，会变成自己的中心线层。
这样可以解决，别人的众多的图层，一个个图改图层。
是否有这样的功能。 下来看看 支持一下 下来看看 这么多下载的，支持回帖的不多……这不对呀！
我顶一下！ 谢谢
下来测试一下 什么功能啊怎么不介绍 cad本身就有laytrans 谢谢楼主的分享。试一下 支持一下，能否贴个动画让大家看得更明白一些 谢谢楼主的好资料！！！