Select all hatches on given layer and move them to new layer

[stekicarYWNUL]

I am trying to select all entities for each layer that has "4-Hatch" string in it's name and move them to a new layer called "4-Hatch". One layer at a time. Problem is that SelectionSet does not get any Hatch entity. Also, to move hatch to a new layer, is 'oObject.Layer = "4-Hatch"'  enough or not?

Sub AddLayer(sLayerName As String, oLayerColor As AcColor, sLayerLineType As String)
    
    Dim oNewLayer As AcadLayer
   
    'On Error Resume Next
   
    Set oNewLayer = ThisDrawing.Layers.Add(sLayerName)
    oNewLayer.color = oLayerColor
    oNewLayer.Linetype = sLayerLineType
       
End Sub


Public Function SelectAllByLayer(sLayer As String, sSetName As String) As AcadSelectionSet
    
    Dim oSelSet As AcadSelectionSet
    Dim intCode(0 To 1) As Integer
    Dim varData(0 To 1) As Variant
    
    intCode(0) = 8
    varData(0) = sLayer
    'intCode(1) = 0
    'varData(1) = "INSERT"
    
    On Error Resume Next
    Err.Clear
    Set oSelSet = ThisDrawing.SelectionSets.Item(sSetName)
    If Err.Number > 0 Then
        oSelSet.Clear
        Err.Clear
    Else
        Set oSelSet = ThisDrawing.SelectionSets.Add(sSetName)
    End If
    
    oSelSet.Select acSelectionSetAll, , , intCode, varData
    
    Set SelectAllByLayer = oSelSet
    
End Function


Public Function GetSelectionAsArray(oSS As AcadSelectionSet)
    
    Dim lEnt As Long
    
    ReDim oObjects(0 To oSS.count - 1) As AcadEntity
    
    For lEnt = 0 To oSS.count - 1
            Set oObjects(lEnt) = oSS.Item(lEnt)
    Next lEnt
    
    GetSelectionAsArray = oObjects
    
End Function


Public Sub MoveAllToLayer(sLayerName As String, sActDrw As String)
    'LINETYPES: ByLayer, ByBlock, Center, CONTINUOUS, DASHED, DOT, HIDDEN, PHANTOM
    'COLORS: acBlue, acByBlock, acByLayer, acCyan, acGreen, acMagenta, acRed, acWhite, acYellow
    'sActDrw: PRT, ASM
    
    Dim oObject As Variant
    Dim oColor As AcColor
    Dim sLineType As String
    Dim oLayer As AcadLayer
    Dim oSelSet As AcadSelectionSet
    'Dim oSelArray() As AcadObject 'Is this properly declared variable?
       
    Select Case sLayerName
    Case "4-Hatch"
        Debug.Print "4-Hatch"
        oColor = 8
        sLineType = "CONTINUOUS"
    Case Else
        Debug.Print "Not correct layer name.: & sLayerName"
        Exit Sub
    End Select
    
    On Error Resume Next
    ThisDrawing.ActiveLayer = ThisDrawing.Layers(sLayerName)
    If Error > 0 Then
        Call AddLayer(sLayerName, oColor, sLineType)
    End If
    On Error GoTo 0
    
    For Each oLayer In ThisDrawing.Layers
        ' If drawing is assembly do not work on any top assembly layer
        If sActDrw = "ASM" Then
            If Left(ThisDrawing.Name, 14) = Left(oLayer.Name, 14) Then
                Debug.Print oLayer.Name
                GoTo ContinueLoop:
            End If
        End If
        
        ' Check if given layer name is within layer name
        If InStr(1, oLayer.Name, UCase(sLayerName)) > 0 Then
            Set oSelSet = SelectAllByLayer(oLayer.Name, oLayer.Name)
            'If oSelSet.count > 0 Then
            '    oSelArray = GetSelectionAsArray(oSelSet)
            'End If
            
            If oSelSet.count > 0 Then
                For Each oObject In GetSelectionAsArray(oSelSet) 'oSelArray
                    oObject.Layer = sLayerName
                Next
            End If
            
            ' Delete selection set - not needed anymore
            oSelSet.Delete
        End If
ContinueLoop:
    Next
    
End Sub



Public Sub TestRun()

    Call MoveAllToLayer("4-Hatch", "ASM")

    ThisDrawing.PurgeAll
    
End Sub

--Moderator edit: change code format to VB.

[1wildwes]

Create the new layer. Use Select Similar to select the hatches.  In Properties use the top drop-down to select the hatches. In Properties change the layer to the new layer.

[stekicarYWNUL]

Thank you for reply. My post is for how to use VBA to accomplish this.

[Ed__Jobe]

Make the following changes. I didn't have time to test it, so let me know if there's an issue. BTW, since your argument for linetype in the AddLayer function is just a string, you should check to see if it's loaded before attempting to assign it to a layer.

Sub AddLayer(sLayerName As String, oLayerColor As AcColor, sLayerLineType As String)
    
    Dim oNewLayer As AcadLayer
   
    On Error Resume Next 'Uncommented
    'Comment out
    'Set oNewLayer = ThisDrawing.Layers.Add(sLayerName) 'Comment out

''Add, this checks for error when layer already exists
    Set oNewLayer = ThisDrawing.Layers.Add(sLayerName)
    If oNewLayer Is Nothing Then
      Set oNewLayer = ThisDrawing.Layers.Item(sLayerName)
    End If
    With oNewLayer
      .color = oLayerColor
      .Linetype = sLayerLineType
    End With
''Add end
       
End Sub


Public Function SelectAllByLayer(sLayer As String, sSetName As String) As AcadSelectionSet
    
    Dim oSelSet As AcadSelectionSet
    Dim intCode(0 To 1) As Integer
    Dim varData(0 To 1) As Variant
    
    intCode(0) = 8
    varData(0) = sLayer
    intCode(1) = 0  'intCode(1) = 0
    varData(1) = "HATCH"  'varData(1) = "INSERT"
    
    On Error Resume Next
    Err.Clear
    Set oSelSet = AddSelectionSet(sSetName) 'Use new function
'    If Err.Number > 0 Then
'        oSelSet.Clear
'        Err.Clear
'    Else
'        Set oSelSet = ThisDrawing.SelectionSets.Add(sSetName)
'    End If
    
    oSelSet.Select acSelectionSetAll, , , intCode, varData
    
    Set SelectAllByLayer = oSelSet
    
End Function

'Add Function
Public Function SStoArray(ss As AcadSelectionSet, ary() As AcadEntity)

    Dim cnt As Integer
    cnt = ss.Count() - 1
    Dim i As Integer
    ReDim ary(0)
    For i = 0 To cnt
        Set ary(i) = ss(i)
        If i < cnt Then ReDim Preserve ary(UBound(ary) + 1)
    Next
    SStoArray = ary
    
End Function

'Public Function GetSelectionAsArray(oSS As AcadSelectionSet)
    
'    Dim lEnt As Long
    
'    ReDim oObjects(0 To oSS.count - 1) As AcadEntity
    
'    For lEnt = 0 To oSS.count - 1
'            Set oObjects(lEnt) = oSS.Item(lEnt)
'    Next lEnt
    
'    GetSelectionAsArray = oObjects
    
'End Function


Public Sub MoveAllToLayer(sLayerName As String, sActDrw As String)
    'LINETYPES: ByLayer, ByBlock, Center, CONTINUOUS, DASHED, DOT, HIDDEN, PHANTOM
    'COLORS: acBlue, acByBlock, acByLayer, acCyan, acGreen, acMagenta, acRed, acWhite, acYellow
    'sActDrw: PRT, ASM
    
    'Dim oObject As Variant 'Comment out
    Dim oEnt As AcadEntity  'Add
    Dim oColor As AcColor
    Dim sLineType As String
    Dim oLayer As AcadLayer
    Dim oSelSet As AcadSelectionSet
    'Dim oSelArray() As AcadObject 'Is this properly declared variable?
       
    Select Case sLayerName
    Case "4-Hatch"
        Debug.Print "4-Hatch"
        oColor = 8
        sLineType = "CONTINUOUS"
    Case Else
        Debug.Print "Not correct layer name.: & sLayerName"
        Exit Sub
    End Select
    
    On Error Resume Next
    ThisDrawing.ActiveLayer = ThisDrawing.Layers(sLayerName)
    If Error > 0 Then
        Call AddLayer(sLayerName, oColor, sLineType)
    End If
    On Error GoTo 0
    
    For Each oLayer In ThisDrawing.Layers
        ' If drawing is assembly do not work on any top assembly layer
        If sActDrw = "ASM" Then
            If Left(ThisDrawing.Name, 14) = Left(oLayer.Name, 14) Then
                Debug.Print oLayer.Name
                GoTo ContinueLoop:
            End If
        End If
        
        ' Check if given layer name is within layer name
        If InStr(1, oLayer.Name, UCase(sLayerName)) > 0 Then
            Set oSelSet = SelectAllByLayer(oLayer.Name, oLayer.Name)
            'If oSelSet.count > 0 Then
            '    oSelArray = GetSelectionAsArray(oSelSet)
            'End If
            
            If oSelSet.count > 0 Then
                'For Each oEnt In GetSelectionAsArray(oSelSet) 'oSelArray
                For Each oEnt In oSelSet 'Add. Since the ss is a collection, you can iterate it.
                    'oObject.Layer = sLayerName
                    oEnt.Layer = sLayerName
                Next
            End If
            
            ' Delete selection set - not needed anymore
            oSelSet.Delete
        End If
ContinueLoop:
    Next
    
End Sub

''ADD SUB
Public Function AddSelectionSet(SetName As String) As AcadSelectionSet
' This routine does the error trapping neccessary for when you want to create a
' selectin set. It takes the proposed name and either adds it to the selectionsets
' collection or sets it.
    On Error Resume Next
    Set AddSelectionSet = ThisDrawing.SelectionSets.Add(SetName)
    If Err.Number <> 0 Then
        Set AddSelectionSet = ThisDrawing.SelectionSets.Item(SetName)
        AddSelectionSet.Clear
    End If
End Function


Public Sub TestRun()

    Call MoveAllToLayer("4-Hatch", "ASM")

    ThisDrawing.PurgeAll
    
End Sub

[stekicarYWNUL]

Ed,

Thank you for reply. My code is rough sketch, I just wanted to check what works and what's not.

DGW file is made from PTC Creo so I have to take this into consideration. After further looking into properties, I realized that these "hatches" are NOT hatches at all. They are AcadBlockReference! And this changes a lot! I guess, Creo export hatches as blocks.

Back to 0.

What would be search filter for blocks and how to move them to new layer? Just using (8, LayerName) does not work, hence the search for "hatches".

Thank you for your help.

[Ed__Jobe]

Not 'back to 0'. You just need to change your ss filter.

SelectionSet filters use dxf codes. The dxf code for block references is "INSERT". You can also use my lisp in this post.

[stekicarYWNUL]

Ed,

In my code I was playing with INSERT:

    intCode(0) = 8
    varData(0) = sLayer
    'intCode(1) = 0
    'varData(1) = "INSERT"

And it did not work. That is why I was trying to filter for hatch, wrongly thou.

Does, order come in play for filters? For, example:

    intCode(0) = 0
    varData(0) = "INSERT"
    intCode(1) = 8
    varData(1) = sLayer

[Ed__Jobe]

No, the order is not important, as long as you have the correct pairs. There might be another reason that it's not finding the block references. 

The following test finds 2 blocks in your test.dwg. I would suggest looking to make sure that your logic to find "4-block" within the layer name is valid.

Public Sub filterTest()
    Dim sLay As String
    Dim ss As AcadSelectionSet
    Set ss = SelectAllByLayer("LERH50K_ROTARY_ACTUATOR4-HATCH", "layertest")
    MsgBox "blocks found = " & ss.Count, vbOKOnly, "SelectionSet Filter Test"
End Sub

[stekicarYWNUL]

I made new test code:

Public Sub Test1()

    Dim filterType(0 To 1) As Integer
    Dim filterData(0 To 1) As Variant
    Dim MySelection As AcadSelectionSet
    Dim oEntity As AcadEntity

    'LERH50K_ROTARY_ACTUATOR4-HATCH
    'SWSB-HX-D26-V20-T10_WASH4-HATCH
    
    filterType(0) = 0:  filterData(0) = "INSERT"
    filterType(1) = 8:  filterData(1) = "LERH50K_ROTARY_ACTUATOR4-HATCH"
    
    On Error Resume Next
    ThisDrawing.SelectionSets("PP1").Delete
    On Error GoTo 0
    Set MySelection = ThisDrawing.SelectionSets.Add("PP1")
    
    MySelection.Select acSelectionSetAll, , , filterType, filterData
    
    For Each oEntity In MySelection
        oEntity.Layer = "0"
    Next
    
    MySelection.Delete
    
End Sub

This one finds blocks but it does not move blocks to "0" layer. Do I have to do something additionally to block so it can move to new layer?

[Ed__Jobe]

    For Each oEntity In MySelection
        oEntity.Layer = "0"
        oEntity.Update
    Next

If your reason for moving the blocks to layer 0 is so that they take on the color of the layer they are on, you don't change the insert's layer, you need to change all the block entities layer to 0 and color to ByLayer or ByBlock.

[stekicarYWNUL]

One more thing.

I figured out why it could not detect blocks sometimes. When I run code first time on newly open test file, code finds blocks. Then, it tries to move them to new layer. When I check drawing, nothing happens, aka nothing moved. BUT! When I run same code for second time for same layer (for ex. LERH50K_ROTARY_ACTUATOR4-HATCH), code finds nothing.  And this is because blocks are in "0" layer (when I moved them in first code run). If I run code to search in "0" then code finds blocks.

[Ed__Jobe]

I was editing my post when you replied. See what I added. Also, when you post code, don't forget to select the language.

[stekicarYWNUL]

I do not care about colors, I just want to move block to new layer. How can I do that? How to get to each block entity? Can I iterate through block's entities just like block is collector?

[Ed__Jobe]

You already moved the block reference to a new layer. You just needed to add the Update method. Of course, the next time you run the sub, you're not going to find any blocks on the same layer, they will be on the new layer. What else do you want??

To iterate a block definition, you need to get the block definition's name from the block reference's Name property, or EffectiveName property if it's a dynamic block. Then search the Block table for the definition, then get it's entities using the block.Items property. See the following sub.

Public Sub BlockEntsByLayer()
    Dim oblk As AcadBlock
    Dim oBlk1 As AcadBlock
    Dim oBlkRef As AcadBlockReference
    Dim oBlkRef1 As AcadBlockReference
    Dim oEnt As AcadEntity
    Dim oEnt1 As AcadEntity
    Dim SS As AcadSelectionSet

    Set SS = GetSS_BlockFilter
    For Each oBlkRef In SS
        Set oblk = ThisDrawing.Blocks(oBlkRef.Name)
        If Not oblk.IsXRef Then
            For Each oEnt In oblk
                If TypeOf oEnt Is AcadBlockReference Then
                    Set oBlkRef1 = oEnt
                    Set oBlk1 = ThisDrawing.Blocks(oBlkRef1.Name)
                    For Each oEnt1 In oBlk1
                        With oEnt1
                            If Not ThisDrawing.Layers(.Layer).Lock Then
                                .Layer = "0"
                                .color = acByLayer
                            End If
                        End With
                    Next oEnt1
                Else
                    With oEnt
                        If Not ThisDrawing.Layers(.Layer).Lock Then
                            .Layer = "0"
                            .color = acByLayer
                        End If
                    End With
                End If
            Next oEnt
        End If
    Next oBlkRef
    ThisDrawing.Regen acAllViewports
End Sub

[stekicarYWNUL]

That's what I want! Thank you!

I thought that if I move block it will move it's entities to new layer which is not the case. I am using VBA "locals" windows to check variable properties, and I did not see any property that acts as a collector for entities inside block. Your code helped me understand that there is also AcadBlock entity.

Your code work as expected. I alter it to work for my test code:

Public Sub BlockEntsByLayer(oBlkRef As AcadBlockReference)

    Dim oBlkRef1 As AcadBlockReference
    Dim oblk As AcadBlock
    Dim oBlk1 As AcadBlock
    Dim oEnt As AcadEntity
    Dim oEnt1 As AcadEntity

    Set oblk = ThisDrawing.Blocks(oBlkRef.Name)
    If Not oblk.IsXRef Then
        For Each oEnt In oblk
            If TypeOf oEnt Is AcadBlockReference Then
                Set oBlkRef1 = oEnt
                Set oBlk1 = ThisDrawing.Blocks(oBlkRef1.Name)
                For Each oEnt1 In oBlk1
                    With oEnt1
                        If Not ThisDrawing.Layers(.Layer).Lock Then
                            .Layer = oBlkRef.Layer '"0"
                            .color = acByLayer
                        End If
                    End With
                Next oEnt1
            Else
                With oEnt
                    If Not ThisDrawing.Layers(.Layer).Lock Then
                        .Layer = oBlkRef.Layer '"0"
                        .color = acByLayer
                    End If
                End With
            End If
        Next oEnt
    End If
    
End Sub


Public Sub Test1()

    Dim filterType(0 To 1) As Integer
    Dim filterData(0 To 1) As Variant
    Dim MySelection As AcadSelectionSet
    Dim oEntity As AcadEntity 'AcadBlockReference
    Dim oBlockEnt As AcadEntity

    'LERH50K_ROTARY_ACTUATOR4-HATCH
    'SWSB-HX-D26-V20-T10_WASH4-HATCH
    
    filterType(0) = 0:  filterData(0) = "INSERT"
    filterType(1) = 8:  filterData(1) = "0"
    
    On Error Resume Next
    ThisDrawing.SelectionSets("PP1").Delete
    On Error GoTo 0
    Set MySelection = ThisDrawing.SelectionSets.Add("PP1")
    
    MySelection.Select acSelectionSetAll, , , filterType, filterData
    
    For Each oEntity In MySelection
        oEntity.Layer = "LERH50K_ROTARY_ACTUATOR4-HATCH" '"0"
        oEntity.Update
        Call BlockEntsByLayer(oEntity)
    Next
    
    MySelection.Delete
    ThisDrawing.Regen acAllViewports
    Debug.Print "STOP!"
    
End Sub

When I finish my code I will post it here for others to use if needed. Bet those Creo guys might need something like this.

[Ed__Jobe]

Don't forget to utilize functions to perform special tasks and make your code modular and reusable. This is especially true if you need to implement On Error Resume Next. Keep that type of flow contained in a separate function.

[stekicarYWNUL]

Thank you for your help.

Currently, I am trying to get code running as it should. I usually  make code work first and then I split code into more manageable functions.

I thought that AutoCAD object model would be similar to Inventor's one, but it is not even close.

[Ed__Jobe]

You're welcome.

It's faster in the long run creating functions that do only one thing. That way you can test it once and be done. If you constantly rewrite code, then you increase the chance you will make a typo and have to debug something that should have already be written. Also, it just saves you from extra typing since you just call the function name.