Jump to content
johanlang

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

Recommended Posts

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...

Share this post


Link to post
Share on other sites
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 by spiff88

Share this post


Link to post
Share on other sites
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 ?

Share this post


Link to post
Share on other sites
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

Share this post


Link to post
Share on other sites
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

Share this post


Link to post
Share on other sites
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

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now

×