Skip to content

Blocks

Loop through all Blocks in active drawing

Sub test()
    Dim cadApp As AcadApplication
    Set cadApp = GetObject(, "autocad.Application")

    Dim cadDoc As AcadDocument
    Set cadDoc = cadApp.ActiveDocument

    Dim cadModel As AcadModelSpace
    Set cadModel = cadDoc.ModelSpace

    Dim entity As AcadEntity

    Dim ATTRIB_LIST  As Variant
    Dim attributeRef As AcadAttributeReference
    'Loop Through All Entity in Cad Model
    For Each entity In cadModel

        'Filter Block Entity
        If entity.ObjectName = "AcDbBlockReference" Then
            'Filter Specific Block using Name
            If entity.EffectiveName = "Pole" Then
                'Check if block contain Attributes
                If entity.HasAttributes = "True" Then
                    ATTRIB_LIST = entity.GetAttributes
                    Set attributeRef = ATTRIB_LIST(0)
                    Debug.Print attributeRef.TextString
                    attributeRef.TextString = "P1"
                End If
            End If
        End If
    Next
End Sub
Referance: Get value block attributes from AutoCAD into excel with VBA

Code to Move and rotate Blocks

Public Sub Test()
    On Error GoTo ErrorHandler

    'Autocad Application
    Dim cadApp As AutoCAD.AcadApplication
    Set cadApp = GetObject(, "autocad.application")

    'Autocad Document
    Dim cadDoc As AutoCAD.AcadDocument
    Set cadDoc = cadApp.ActiveDocument

    'Autocad ModelSpace
    Dim cadModel As AutoCAD.AcadModelSpace
    Set cadModel = cadDoc.ModelSpace

    'Loop through each entity
    Dim i As Integer
    Dim cadEntity As AutoCAD.AcadEntity
    Dim cadBlockRef As AutoCAD.AcadBlockReference

     Dim BasePoint(0 To 2) As Double
        'top left corner of text
    BasePoint(0) = 0: BasePoint(1) = 0: BasePoint(2) = 0

    For i = 0 To 0                               'cadModel.Count - 1
        'Convert Item to Cad Entity
        Set cadEntity = cadModel.Item(i)
        If cadEntity.ObjectName = "AcDbBlockReference" Then
            Set cadBlockRef = cadEntity
            cadBlockRef.InsertionPoint(0) = 0
            cadBlockRef.InsertionPoint(1) = 0
            'Get Insertion Point And rotation
            Debug.Print cadBlockRef.Name, cadBlockRef.InsertionPoint(0), cadBlockRef.InsertionPoint(1), cadBlockRef.Rotation
            cadBlockRef.Rotate cadBlockRef.InsertionPoint, 0.785
            cadBlockRef.Move cadBlockRef.InsertionPoint, BasePoint
        End If
    Next



Done:
    Exit Sub
ErrorHandler:
    If Err.Description <> "" Then
        MsgBox (Err.Description)
    End If
End Sub