Jump to content

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


johanlang

Recommended Posts

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

Link to comment
Share on other sites

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

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 ?

Link to comment
Share on other sites

  • 3 months later...

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...