Changing Layers base on theirs names

Hi,

I have asked this question regarding the scripts commands, now I am looking
for VBA solution,I need a bunch of codes that can change the color of the
layers that has specific words on theirs names, like ( molding ) for
example.

Thanks in advance

 

Hi A-Design

Try one of this:

Code:

Sub ChangeLayerColor()		'< 2k4

Dim LayArr(0 To 3, 1) As Variant
Dim LayObj As AcadLayer
Dim ArrCnt As Integer
'Layer name		Color
LayArr(0, 0) = "*025*": LayArr(0, 1) = acRed
LayArr(1, 0) = "*035*": LayArr(1, 1) = acGreen
LayArr(2, 0) = "*050*": LayArr(2, 1) = acBlue

For Each LayObj In ThisDrawing.Layers
For ArrCnt = 0 To UBound(LayArr)
If LayObj.Name Like LayArr(ArrCnt, 0) Then
LayObj.Color = LayArr(ArrCnt, 1)
Exit For
End If
Next ArrCnt
Next LayObj

End Sub

Sub ChangeLayerTrueColor()	'> 2k2

Dim LayArr(0 To 2, 3) As Variant
Dim LayObj As AcadLayer
Dim ArrCnt As Integer
Dim ColObj As AcadAcCmColor

Set ColObj = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
'Layer name		 ColorRed      ColorGreen      ColorBlue
LayArr(0, 0) = "*025*": LayArr(0, 1) = 255: LayArr(0, 2) = 0: LayArr(0, 3) = 0
LayArr(1, 0) = "*035*": LayArr(1, 1) = 0: LayArr(1, 2) = 255: LayArr(1, 3) = 0
LayArr(2, 0) = "*050*": LayArr(2, 1) = 0: LayArr(2, 2) = 0: LayArr(2, 3) = 255

For Each LayObj In ThisDrawing.Layers
For ArrCnt = 0 To UBound(LayArr)
If LayObj.Name Like LayArr(ArrCnt, 0) Then
ColObj.SetRGB LayArr(ArrCnt, 1), LayArr(ArrCnt, 2), LayArr(ArrCnt, 3)
LayObj.TrueColor = ColObj
Exit For
End If
Next ArrCnt
Next LayObj

Set ColObj = Nothing

End Sub

Cheers

 

Oops, small typo:

Code:

Sub ChangeLayerColor()          '< 2k4

Dim LayArr(0 To 3, 1) As Variant
...
must be

Sub ChangeLayerColor()          '< 2k4

Dim LayArr(0 To 2, 1) As Variant
...

Cheesr

 

Thanks Jürg,
Afshin

 

Hi Afshin

Glad to help you...¦-)

Cheers