+ Reply to Thread
Results 1 to 6 of 6
  1. #1
    Forum Newbie
    Discipline
    Construction
    Using
    AutoCAD 2014
    Join Date
    Apr 2017
    Posts
    5

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

    Registered forum members do not see this ad.

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

  2. #2
    Junior Member spiff88's Avatar
    Computer Details
    spiff88's Computer Details
    Operating System:
    Windows 7 SP1
    Computer:
    Dell Precision T3600
    CPU:
    Intel Xeon E5-1650 @ 3.2 GHz
    RAM:
    16 GB
    Graphics:
    NVIDIA Quadro 600
    Primary Storage:
    600 MB
    Secondary Storage:
    2 GB
    Monitor:
    dual 1920x1080
    Using
    AutoCAD 2015
    Join Date
    Oct 2008
    Location
    Portland, OR
    Posts
    10

    Default

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

    Code:
    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.
    Last edited by spiff88; 5th May 2017 at 02:30 pm.

  3. #3
    Luminous Being
    Using
    Civil 3D 2016
    Join Date
    Dec 2005
    Location
    GEELONG AUSTRALIA
    Posts
    9,815

    Default

    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 ?
    A man who never made mistakes never made anything

  4. #4
    Full Member
    Using
    AutoCAD 2010
    Join Date
    Oct 2013
    Posts
    78

    Default

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

    Code:
    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

  5. #5
    Luminous Being
    Using
    Civil 3D 2016
    Join Date
    Dec 2005
    Location
    GEELONG AUSTRALIA
    Posts
    9,815

    Default

    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
    A man who never made mistakes never made anything

  6. #6
    Full Member
    Using
    AutoCAD 2010
    Join Date
    Oct 2013
    Posts
    78

    Default

    Registered forum members do not see this ad.

    With
    Code:
    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

Similar Threads

  1. Change layer of Block Elements
    By hosannabizarre in forum AutoLISP, Visual LISP & DCL
    Replies: 17
    Last Post: 22nd Jan 2014, 08:37 am
  2. Offsetting drawing elements to a different layer
    By martyn60 in forum Mechanical & MDT
    Replies: 12
    Last Post: 20th Oct 2010, 03:07 pm
  3. Applying layer changes to existing elements
    By ihavenolife in forum AutoCAD Beginners' Area
    Replies: 18
    Last Post: 12th Feb 2008, 04:38 pm
  4. change an elements layer
    By studiorat in forum AutoCAD General
    Replies: 8
    Last Post: 3rd Jan 2008, 05:57 pm
  5. Macro to remove all layer filters and purge a drawing
    By corradophil in forum AutoLISP, Visual LISP & DCL
    Replies: 6
    Last Post: 6th Jun 2006, 04:11 pm

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts