vba macro to move all red elements in the drawing to one layer

[johanlang]

Hi All,

 

 

In the drawing, there are a lot of element in diffrent colors and all are in layer 0.

 

 

How do I do a vba macro to move all red elements in the drawing to one layer, for example to an existing layer named red?

 

 

I need a vba macro which not require any manual input, that dialouge boxes open for user select, etc...

[spiff88]

This VBA code will work from within Excel VBE as long as you set the References to the AutoCAD 20xx Type Library for your version of AutoCAD.

 

To use, open the DWG, then run the code in the Excel VBE. The code loops through all objects in model spaces, the IF-THEN checks the color, and then changes the layer if the color = 1 (red).

 

Sub MoveRedObjects()

Dim objApp As AcadApplication
Dim objDoc As AcadDocument

Set objApp = GetObject(, "AutoCAD.Application")
Set objDoc = objApp.ActiveDocument

   For Each obj In objDoc.ModelSpace
       If obj.Color = 1 Then
           obj.Layer = "red"
       End If
   Next

End Sub

 

Hopefully this does what you need.

Edited May 5, 2017 by spiff88

[BIGAL]

spiff88 probably a good idea to make the new layer Red_layer_name before doing object collection so no crash on layer does not exist.

 

Johanlang an extra question do you have blocks that are all red ?

[RICVBA]

You could narrow down selectionset to filter elements whose color is Red only

 

Sub MoveRedObjects2()
   Dim redsSset As AcadSelectionSet
   Dim acEnt As AcadEntity

   If GetColoredEntities(redsSset, 1) Then
       ThisDrawing.Layers.Add ("Red")
       For Each acEnt in entsSet
           acEnt.Layer = "Red"
       Next
   End If
End Sub

Function GetColoredEntities(redsSset As AcadSelectionSet, color As Integer)
   Dim gpCode(0 to 0) As Integer
   Dim dataValue(0 to 0) As Variant

   gpCode(0) = 62: dataValue(0) = 1 'red color 
   On Error Resume Next
   Set redsSset = ThisDrawing.SelectionSets.Add("Reds")
   On Error GoTo 0
   If redsSset Is Nothing Then Set redsSset = ThisDrawing.SelectionSets.Item("Reds")

   With redsSset
       .Clear
       .Select acSelectionSetAll, , , gpCode, dataValue
       GetColoredEntities = .Count > 0
   End With
End Function

[BIGAL]

there are a lot of element in diffrent colors and all are in layer 0

I would do like above posters make a little sub to check colour layer actually exists, then only difference is I would just make the layer name the colour number and then at end change the layer names to something meaningfull. This way just keep going until end of drawing, if you have rgb colours then layer could be R-G-B 123-100-200

[RICVBA]

With

ThisDrawing.Layers.Add ("Red")

 

It adds the wanted layer if not already there or it does nothing (not even throws any error) if it exists already