CadToExcel.vba

' Extraction of text data from the active AutoCAD drawing and recording it in Excel

Public row As Integer
Public sh As Sheet1

Sub CadToExcel()
    Dim acadApp As AcadApplication
    Dim acadDoc As AcadDocument
    Dim drawingName As String

    Application.StatusBar = "Start"

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    On Error Resume Next
    Set acadApp = GetObject(, "AutoCAD.Application")
    On Error GoTo 0

    If acadApp Is Nothing Then
        Debug.Print "AutoCAD not running or not accessible."
        Exit Sub
    End If

    Set acadDoc = acadApp.ActiveDocument

    If acadDoc Is Nothing Then
        Debug.Print "No drawing open in AutoCAD."
        Exit Sub
    End If

    drawingName = acadDoc.Name
    ExtractDrawingData acadDoc

    Set acadDoc = Nothing
    Set acadApp = Nothing

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
End Sub

Sub ExtractDrawingData(doc As AcadDocument)
    Dim layout As AcadLayout
    Set sh = ThisWorkbook.Sheets(1)
    row = 2
    sh.Cells(1, 1).Value = "doc"
    sh.Cells(1, 2).Value = "layout"
    sh.Cells(1, 3).Value = "block"
    sh.Cells(1, 4).Value = "attribute"
    sh.Cells(1, 5).Value = "oldValue"
    sh.Cells(1, 6).Value = "newValue"
    sh.Cells(row, 1).Value = doc.Name
    RestoreColor sh.Cells(row, 1)
    For Each layout In doc.Layouts
        ExtractLayoutData doc, layout
    Next layout
End Sub

Sub ExtractLayoutData(doc As AcadDocument, layout As AcadLayout)
    Dim bRef As AcadBlockReference
    Dim entity As Object

    row = row + 1
    SetEqualUpper sh.Cells(row, 1)
    sh.Cells(row, 2).Value = layout.Name
    RestoreColor sh.Cells(row, 2)

    For Each entity In layout.Block

        If TypeOf entity Is AcadBlockReference Then
            Set bRef = entity
            ExtractAttrs bRef
        End If
        If TypeOf entity Is AcadMText Then
            ExtractText entity
        End If
        If TypeOf entity Is AcadText Then
            ExtractText entity
        End If

    Next entity
End Sub

Sub ExtractAttrs(bRef As AcadBlockReference)
    If bRef.HasAttributes <> True Then
        row = row + 1
        SetEqualUpper sh.Cells(row, 1)
        SetEqualUpper sh.Cells(row, 2)
        sh.Cells(row, 3).Value = bRef.Name
        sh.Cells(row, 4).Value = "n/a"
        sh.Cells(row, 5).Value = ""
        Exit Sub
    End If

    atts = bRef.GetAttributes
    For attCount = LBound(atts) To UBound(atts)
        row = row + 1
        SetEqualUpper sh.Cells(row, 1)
        SetEqualUpper sh.Cells(row, 2)
        sh.Cells(row, 3).Value = bRef.Name
        sh.Cells(row, 4).Value = atts(attCount).TagString
        sh.Cells(row, 5).Value = atts(attCount).TextString
    Next attCount
End Sub

Sub ExtractText(text As Object)
    row = row + 1
    SetEqualUpper sh.Cells(row, 1)
    SetEqualUpper sh.Cells(row, 2)
    sh.Cells(row, 3).Value = Replace(TypeName(text), "IAcad", "")
    sh.Cells(row, 4).Value = text.FieldCode
    sh.Cells(row, 5).Value = ""
End Sub

Sub SetEqualUpper(range As range)
    range.Formula = "=R[-1]C"
    range.Font.Color = RGB(128, 128, 128)
End Sub

Sub RestoreColor(range As range)
    range.Font.ColorIndex = xlAutomatic
End Sub