通过颜色、线型等改物体图层

subtlation

没有对话框，里面的设置是根据自己的绘图习惯定的。


源码如下：里面一些函数都是明经里面下载的。

2. Sub changelayer()
   
3.   On Error Resume Next
   
4.    '新建选择集
   
5.     Dim ssetObj As AcadSelectionSet
   
6.     Set ssetObj = CreateSelectionSet()
   
7.     ssetObj.SelectOnScreen
   
8.     If ssetObj.Count = 0 Then Exit Sub
   
9.   
   
10.    '新建图层
    
11.     Dim newlayer As AcadLayer
    
12.     Set newlayer = CreateLayer("A1", acRed)
    
13.       newlayer.Lineweight = acLnWt050
    
14.     Set newlayer = CreateLayer("A2", acYellow)
    
15.       newlayer.Lineweight = acLnWt025
    
16.     Set newlayer = CreateLayer("A3", acGreen)
    
17.       newlayer.Lineweight = acLnWt025
    
18.     Set newlayer = CreateLayer("A4", acCyan)
    
19.       newlayer.Lineweight = acLnWt035
    
20.     Set newlayer = CreateLayer("A5", acBlue)
    
21.       newlayer.Lineweight = acLnWt070
    
22.     Set newlayer = CreateLayer("A6", acMagenta)
    
23.       newlayer.Lineweight = acLnWt013
    
24.     Set newlayer = CreateLayer("C6", acMagenta, "CENTER")
    
25.       newlayer.Lineweight = acLnWt013
    
26.     Set newlayer = CreateLayer("HATCH")
    
27.       newlayer.Lineweight = acLnWt018
    
28.     Set newlayer = CreateLayer("NOTE")
    
29.       newlayer.Lineweight = acLnWt018
    
30.     Set newlayer = CreateLayer("DIM")
    
31.       newlayer.Lineweight = acLnWt018
    
32.     Set newlayer = CreateLayer("钢筋编号")
    
33.       newlayer.Lineweight = acLnWt018
    
34.     Set newlayer = CreateLayer("标高")
    
35.       newlayer.Lineweight = acLnWt018
    
36.    
    
37.    
    
38.     Dim ent As AcadEntity
    
39.     For Each ent In ssetObj
    
40.       '根据颜色改变改图层
    
41.       colorTolayer ent, acRed, "A1"
    
42.       colorTolayer ent, acYellow, "A2"
    
43.       colorTolayer ent, acGreen, "A3"
    
44.       colorTolayer ent, acCyan, "A4"
    
45.       colorTolayer ent, acBlue, "A5"
    
46.       '所有标注变成DIM层
    
47.       '所有文字变成NOTE层
    
48.       '所有填充变成HATCH层
    
49.       '所有钢筋编号改为钢筋编号层
    
50.       If TypeOf ent Is AcadDimension Then
    
51.         ent.Layer = "DIM"
    
52.       ElseIf TypeOf ent Is AcadHatch Then
    
53.         ent.Layer = "HATCH"
    
54.       ElseIf TypeOf ent Is AcadMText Or TypeOf ent Is AcadText Then
    
55.         ent.Layer = "NOTE"
    
56.       ElseIf TypeOf ent Is AcadBlockReference Then
    
57.         If ent.Name Like "钢筋编号*" Then
    
58.           ent.Layer = "钢筋编号"
    
59.         ElseIf ent.Name Like "BG??" Or ent.Name Like "*标高" Then
    
60.           ent.Layer = "标高"
    
61.         End If
    
62.       End If
    
63.     Next
    
64.    
    
65.     ssetObj.Clear
    
66.     ssetObj.Delete
    
67.     ThisDrawing.PurgeAll
    
68. End Sub
    
69. Sub colorTolayer(ent As AcadEntity, Color As Integer, layerName As String)
    
70.   If ent.Color = Color Then
    
71.     ent.Layer = layerName
    
72.     ent.Color = acByLayer
    
73.   End If
    
74. End Sub
    
75. Public Function CreateLayer(ssLayerName As String, Optional LayerColor As Integer, _
    
76.                             Optional LayerLineType As String) As AcadLayer
    
77. On Error Resume Next
    
78.     Set CreateLayer = ThisDrawing.Layers(ssLayerName)
    
79.     If Err Then
    
80.         Err.Clear
    
81.         Set CreateLayer = ThisDrawing.Layers.Add(ssLayerName)
    
82.         If LayerColor <> 0 Then CreateLayer.Color = LayerColor
    
83.         If LayerLineType <> "" Then CreateLayer.Linetype = LayerLineType
    
84.     End If
    
85. End Function
    
86. 
    
87. Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
    
88.   '返回一个空白选择集
    
89.   
    
90.     Dim ss As AcadSelectionSet
    
91.    
    
92.     On Error Resume Next
    
93.     Set ss = ThisDrawing.SelectionSets(ssName)
    
94.     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    
95.     ss.Clear
    
96.     Set CreateSelectionSet = ss
    
97. End Function
    
98. 
    
99. 
    

Sub changelayer()<br />   On Error Resume Next<br />    '新建选择集<br />     Dim ssetObj As AcadSelectionSet<br />     Set ssetObj = CreateSelectionSet()<br />     ssetObj.SelectOnScreen<br />     If ssetObj.Count = 0 Then Exit Sub<br />   <br />    '新建图层<br />     Dim newlayer As AcadLayer<br />     Set newlayer = CreateLayer("A1", acRed)<br />       newlayer.Lineweight = acLnWt050<br />     Set newlayer = CreateLayer("A2", acYellow)<br />       newlayer.Lineweight = acLnWt025<br />     Set newlayer = CreateLayer("A3", acGreen)<br />       newlayer.Lineweight = acLnWt025<br />     Set newlayer = CreateLayer("A4", acCyan)<br />       newlayer.Lineweight = acLnWt035<br />     Set newlayer = CreateLayer("A5", acBlue)<br />       newlayer.Lineweight = acLnWt070<br />     Set newlayer = CreateLayer("A6", acMagenta)<br />       newlayer.Lineweight = acLnWt013<br />     Set newlayer = CreateLayer("C6", acMagenta, "CENTER")<br />       newlayer.Lineweight = acLnWt013<br />     Set newlayer = CreateLayer("HATCH")<br />       newlayer.Lineweight = acLnWt018<br />     Set newlayer = CreateLayer("NOTE")<br />       newlayer.Lineweight = acLnWt018<br />     Set newlayer = CreateLayer("DIM")<br />       newlayer.Lineweight = acLnWt018<br />     Set newlayer = CreateLayer("钢筋编号")<br />       newlayer.Lineweight = acLnWt018<br />     Set newlayer = CreateLayer("标高")<br />       newlayer.Lineweight = acLnWt018<br />     <br />     <br />     Dim ent As AcadEntity<br />     For Each ent In ssetObj<br />       '根据颜色改变改图层<br />       colorTolayer ent, acRed, "A1"<br />       colorTolayer ent, acYellow, "A2"<br />       colorTolayer ent, acGreen, "A3"<br />       colorTolayer ent, acCyan, "A4"<br />       colorTolayer ent, acBlue, "A5"<br />       '所有标注变成DIM层<br />       '所有文字变成NOTE层<br />       '所有填充变成HATCH层<br />       '所有钢筋编号改为钢筋编号层<br />       If TypeOf ent Is AcadDimension Then<br />         ent.Layer = "DIM"<br />       ElseIf TypeOf ent Is AcadHatch Then<br />         ent.Layer = "HATCH"<br />       ElseIf TypeOf ent Is AcadMText Or TypeOf ent Is AcadText Then<br />         ent.Layer = "NOTE"<br />       ElseIf TypeOf ent Is AcadBlockReference Then<br />         If ent.Name Like "钢筋编号*" Then<br />           ent.Layer = "钢筋编号"<br />         ElseIf ent.Name Like "BG??" Or ent.Name Like "*标高" Then<br />           ent.Layer = "标高"<br />         End If<br />       End If<br />     Next<br />     <br />     ssetObj.Clear<br />     ssetObj.Delete<br />     ThisDrawing.PurgeAll<br /> End Sub<br /> Sub colorTolayer(ent As AcadEntity, Color As Integer, layerName As String)<br />   If ent.Color = Color Then<br />     ent.Layer = layerName<br />     ent.Color = acByLayer<br />   End If<br /> End Sub<br /> Public Function CreateLayer(ssLayerName As String, Optional LayerColor As Integer, _<br />                             Optional LayerLineType As String) As AcadLayer<br /> On Error Resume Next<br />     Set CreateLayer = ThisDrawing.Layers(ssLayerName)<br />     If Err Then<br />         Err.Clear<br />         Set CreateLayer = ThisDrawing.Layers.Add(ssLayerName)<br />         If LayerColor <> 0 Then CreateLayer.Color = LayerColor<br />         If LayerLineType <> "" Then CreateLayer.Linetype = LayerLineType<br />     End If<br /> End Function<br /> <br /> Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet<br />   '返回一个空白选择集<br />   <br />     Dim ss As AcadSelectionSet<br />     <br />     On Error Resume Next<br />     Set ss = ThisDrawing.SelectionSets(ssName)<br />     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)<br />     ss.Clear<br />     Set CreateSelectionSet = ss<br /> End Function<br /> <br /> <br />

chengzhang

好好学习，天天向上！

清风明月名字

谢谢楼主代码分享！