Select blocks on drawing based on attribute value and change all to specific layer

[nick.atwell5H5BS]

Hello!

I am fairly novice to VBA in AutoCAD but have worked with it in Excel. What I'm trying to do is select blocks on a drawing that have a specific attribute value and change those blocks to a specific layer. I know I can do this with the find command and manually changing the layers, but I need to loop through several attribute values and put each selection set on a different layer.

I've tried searching other posts to see how to do this, but my code never seems to work.

Any help is much appreciated! Thanks!

[grobnik]

Hi, here below a simple way to catch block and related attributes from drawing, and transfer to excel.

What you have to pay attention inside this procedure is

qq = BlkRef.GetAttributes
            For X = LBound(qq) To UBound(qq)

In this way you got block attributes which will be store in the array qq.

If you want to be sure that the block has attributes you can add

If BlkRef.HasAttributes=true then

...

end if

Later you can check the attribute you want to check with TAGSTRING and TEXTSTRING, respectively the Attribute Name and Value.

The attribute sequence in the array from 0 to N attribute it's the same of what you are viewing when you modify the attributes locally with form which appear double clicking on block.

            For X = LBound(qq) To UBound(qq)
               ObjExcel.ActiveSheet.Cells(1, X + 1).Value = X
               ObjExcel.ActiveSheet.Cells(2, X + 1).Value = qq(X).TagString
               ObjExcel.ActiveSheet.Cells(3, X + 1).Value = qq(X).TextString
            Next

Private Sub TemplateExcel()
Dim ObjExcel As Object
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet

Set ObjExcel = CreateObject("Excel.Application")
Set xlBook = ObjExcel.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
ObjExcel.Visible = True
ObjExcel.Workbooks(ObjExcel.ActiveWorkbook.Name).Activate
For Each Object In ThisDrawing.ModelSpace
    If TypeOf Object Is AcadBlockReference Or TypeOf Object Is AcadBlock Then
        Set BlkRef = Object
        If BlkRef.HasAttributes = True Then
            Nome = BlkRef.EffectiveName
            If Nome = "BLOCK NAME" Then
                BlkRef.layer="NAME OF LAYER"
            End If
            For Each MySheet In ObjExcel.Sheets
                If MySheet.Name = Nome Then
                    GoTo Qui:
                End If
            Next MySheet
            ObjExcel.ActiveSheet.Name = Nome
            qq = BlkRef.GetAttributes
            For X = LBound(qq) To UBound(qq)
               ObjExcel.ActiveSheet.Cells(1, X + 1).Value = X
               ObjExcel.ActiveSheet.Cells(2, X + 1).Value = qq(X).TagString
               ObjExcel.ActiveSheet.Cells(3, X + 1).Value = qq(X).TextString
            Next
            ObjExcel.Sheets.Add
        End If
    End If
Qui:
    Next
End Sub

[reuter.philipp]

Hello,
I am not sure if I understood your question correctly. If you want to run the script in AutoCAD and not in Excel and you only want to change the layer, I would do it like this:

Public Sub ChangeLayer()
    For Each ModelSpaceObject In ThisDrawing.ModelSpace
        On Error Resume Next
        If ModelSpaceObject.AttributeName = "Your Wanted Attribute" Then
            ModelSpaceObject.Layer = "Your Wanted LAyer"
        ElseIf ModelSpaceObject.AttributeName = "Your other Wanted Attribute" Then
            ModelSpaceObject.Layer = "Your other Wanted LAyer"
        End If
    Next
End Sub

Sometimes the layer "0" causes problems, that's why the On Error Resume Next, alternatively you can remove that and exclude errors directly, with an If condition if ModelSpaceObject.Name = "0", as an example.

Example of possible ModelSpaceObject Attribute:

Otherwise you can write again more precisely, where you run the script and what else you want.

With kind regards,
Philipp

[norman.yuan]

This is a piece of simplified code (not tested):

'' Assume you want to search attribute with given tag and given value

'' If found, change to given layer

Dim attTag As String

Dim attValue As String

Dim layerName as String

'' assume these are input values

attTag="TheAtt"

attValue="TheValue"

layerName="Layer1"

Dim ent As AcadEntity

Dim blk As acadBlockReference

'' Search block references in ModelSpace

For Each ent in ThisDrawing.ModelSpace

  If TypeOf ent Is AcadBlockReference Then

    Set blk=ent

    '' Change block reference's layer according to its attributes

    SetBlockLayer blk, attTag, attValue, layerName

  End If

Next

Private Sub SetBlockLayer(blk As AcadBlockReference, tag As String, val as String, layer As String)

  If Not blk.HasAttributes Then Exit Sub

  Dim i as Integer

  Dim att As AcadAttributeReference

  Dim atts As Variant

  atts=blk.GetAttributes()

  For i-0 to Ubound(atts)

    Set att=atts(i)

    If UCase(att.TagString)=UCase(tag) And UCase(att.TextString)=UCase(val) Then

      blk.Layer=layer

      Exit Sub

    End If

  Next

End Sub

HTH