VBA script doesn't work to export attributes to excel.

[Telles0808]

AutoCAD 2024 Developer and ObjectARX Ajuda | Example: List AutoCAD attributes on an Excel spreadshee...
I'm trying to automate the process of reading DWG files and exporting attribute values to Excel using VBA, similar to the Autodesk example. However, the method doesn't seem to work in AutoCAD 2025, and after several attempts, I was unable to get it to read the attribute values. Did something change in the AutoCAD API that broke the previous approach?

My script is setup to read the block PRANCHA and then find the attributes on it and extract its values, but it doesn't..

Sub ExtrairAtributosMultiplosArquivosR002()
    ' Declarações
    Dim AcadApp As Object
    Dim AcadDoc As Object
    Dim AcadBlockRef As Object
    Dim AcadAttribute As Object
    Dim ws As Worksheet
    Dim Row As Long
    Dim FileDialog As FileDialog
    Dim SelectedFiles As FileDialogSelectedItems
    Dim FileName As Variant ' Ajustado para Variant
    Dim AutoCADInstances As Object
    Dim ConfirmClose As VbMsgBoxResult

    On Error GoTo ErrorHandler

    ' Limpar debug
    Debug.Print String(50, "-") & " Início do Processamento " & String(50, "-")

    ' Fechar instâncias do AutoCAD, se houver
    On Error Resume Next
    Set AutoCADInstances = GetObject(, "AutoCAD.Application")
    On Error GoTo ErrorHandler
    If Not AutoCADInstances Is Nothing Then
        ConfirmClose = MsgBox("Há instâncias do AutoCAD abertas. Deseja fechá-las e continuar?", vbYesNo + vbExclamation, "Fechar AutoCAD")
        If ConfirmClose = vbNo Then
            Debug.Print Now & " - Processo cancelado pelo usuário."
            Exit Sub
        Else
            AutoCADInstances.Quit
            Debug.Print Now & " - Todas as instâncias do AutoCAD foram fechadas."
        End If
    End If

    ' Inicializar AutoCAD
    Set AcadApp = CreateObject("AutoCAD.Application")
    AcadApp.Visible = False
    Debug.Print Now & " - AutoCAD inicializado com sucesso."

    ' Configurar planilha de saída
    Set ws = ThisWorkbook.Sheets(1)
    ws.Cells.Clear
    Row = 1

    ' Seleção de múltiplos arquivos
    Set FileDialog = Application.FileDialog(msoFileDialogFilePicker)
    With FileDialog
        .Title = "Selecione arquivos DWG"
        .Filters.Clear
        .Filters.Add "Desenhos do AutoCAD", "*.dwg"
        .AllowMultiSelect = True
        If .Show = -1 Then
            Set SelectedFiles = .SelectedItems
        Else
            Debug.Print Now & " - Nenhum arquivo selecionado. Processo cancelado."
            Exit Sub
        End If
    End With

    ' Processar cada arquivo selecionado
    For Each FileName In SelectedFiles
        Debug.Print Now & " - Abrindo o arquivo DWG: " & FileName
        Set AcadDoc = AcadApp.Documents.Open(FileName)
        Debug.Print Now & " - Arquivo aberto com sucesso: " & FileName

        ' Escrever o nome do arquivo no Excel
        ws.Cells(Row, 1).Value = "Arquivo"
        ws.Cells(Row, 2).Value = FileName
        Row = Row + 1

        ' Verificar PaperSpace
        Debug.Print Now & " - Iniciando leitura do PaperSpace..."
        For Each AcadBlockRef In AcadDoc.PaperSpace
            On Error Resume Next
            ' Verificar se é um bloco com atributos
            If AcadBlockRef.ObjectName = "AcDbBlockReference" Then
                If AcadBlockRef.Name = "PRANCHA" Then
                    Debug.Print Now & " - Bloco PRANCHA encontrado."
                    ' Iterar pelos atributos do bloco
                    For Each AcadAttribute In AcadBlockRef.GetAttributes
                        ws.Cells(Row, 1).Value = AcadAttribute.TagString ' Tag do atributo
                        ws.Cells(Row, 2).Value = AcadAttribute.TextString ' Valor do atributo
                        Debug.Print Now & " - Atributo encontrado: " & AcadAttribute.TagString & " = " & AcadAttribute.TextString
                        Row = Row + 1
                    Next AcadAttribute
                End If
            End If
            On Error GoTo ErrorHandler
        Next AcadBlockRef

        Debug.Print Now & " - Arquivo fechado: " & FileName
        AcadDoc.Close False
    Next FileName

    ' Fechar AutoCAD
    AcadApp.Quit
    Debug.Print Now & " - Instância do AutoCAD fechada."
    Debug.Print Now & " - Processamento concluído."
    MsgBox "Processamento concluído com sucesso!", vbInformation

    Exit Sub

ErrorHandler:
    Debug.Print Now & " - Erro: " & Err.Description
    If Not AcadApp Is Nothing Then AcadApp.Quit
    MsgBox "Ocorreu um erro: " & Err.Description, vbCritical
End Sub

[grobnik]

Hi @Telles0808 looking at your code seems you are developing the attribute extraction by Excel VBA.

Did you try to do the opposite ? The second question is: Have you done some debug during the code execution ? What the code behaviour ? nothing appears ? No attribute data are extracted from the block ?

Attributes are really inside the block.

If you can share your drawing I guess somebody could check your code, and help you better.

Let us know

[Telles0808 · Accepted solution]

Yes, I debugged every step. Tried even the Autodesk sample for AutoCAD VBA, and it didn't worked, something sounds bugged. You can use my script in any DWG file, it will pick any block with attribute to extract it, but actually it see the block, know which block have attributes but don't extract it, or better, the data is empty.
I did another script using another method, using brute force, and get every attribute in the file, what was a mess, but after several filters, it is working as it should.

Public Sub LEITOR_DE_ATRIBUTOS_R004()
    Dim AcadApp As Object
    Dim AcadDoc As Object
    Dim AcadBlock As Object
    Dim AcadAtt As Object
    Dim ProcessFound As Boolean
    Dim FileNames As Variant
    Dim i As Long
    Dim ExcelSheet As Worksheet
    Dim Row As Long
    
    ' Dicionário para controle de atributos únicos
    Dim UniqueAttributes As Object
    Set UniqueAttributes = CreateObject("Scripting.Dictionary")
    
    Debug.Print "--------------------------------------- Início do Debug ---------------------------------------"
    Debug.Print Now & ": Iniciando processo de exportação."
    
    ' Verifica se o AutoCAD está em execução no início
    ProcessFound = ProcessExist("acad.exe")
    If ProcessFound Then
        Debug.Print Now & ": AutoCAD detectado em execução."
        If MsgBox("AutoCAD está em execução. Deseja fechar todas as instâncias?", _
                 vbQuestion + vbYesNo, "AutoCAD Detectado") = vbYes Then
            Debug.Print Now & ": Fechando todas as instâncias do AutoCAD."
            Set AcadApp = GetObject(, "AutoCAD.Application")
            AcadApp.Quit
            DoEvents
            Wait 2
        End If
    Else
        Debug.Print Now & ": AutoCAD não está em execução."
    End If
    
    ' Inicializa o AutoCAD
    On Error Resume Next
    Set AcadApp = CreateObject("AutoCAD.Application")
    
    If AcadApp Is Nothing Then
        MsgBox "Erro ao iniciar AutoCAD!", vbCritical
        Debug.Print Now & ": Erro ao iniciar AutoCAD!"
        Exit Sub
    End If
    
    With AcadApp
        .Visible = False
        .WindowState = 0
    End With
    Debug.Print Now & ": AutoCAD iniciado com sucesso e interface oculta."
    
    FileNames = Application.GetOpenFilename("Arquivos DWG (*.dwg), *.dwg", MultiSelect:=True)
    If Not IsArray(FileNames) Then
        MsgBox "Nenhum arquivo selecionado!", vbExclamation
        Debug.Print Now & ": Nenhum arquivo selecionado."
        AcadApp.Quit
        Set AcadApp = Nothing
        Exit Sub
    End If
    Debug.Print Now & ": Arquivos selecionados: " & Join(FileNames, ", ")

    ' Prepara a planilha
    Set ExcelSheet = ThisWorkbook.ActiveSheet
    ExcelSheet.Cells.Clear
    ExcelSheet.Cells(1, 1).Value = "Nome do Bloco"
    ExcelSheet.Cells(1, 2).Value = "Tag"
    ExcelSheet.Cells(1, 3).Value = "Valor"
    Row = 2
    
    Application.ScreenUpdating = False
    Debug.Print Now & ": Planilha preparada para exportação."

    ' Processa cada arquivo DWG
    For i = LBound(FileNames) To UBound(FileNames)
        Debug.Print Now & ": Processando arquivo: " & FileNames(i)
        Set AcadDoc = AcadApp.Documents.Open(FileNames(i))
        Set UniqueAttributes = CreateObject("Scripting.Dictionary")
        
        ' Processa ModelSpace
        Debug.Print Now & ": Iniciando processamento do ModelSpace"
        For Each AcadBlock In AcadDoc.ModelSpace
            ' Tenta obter atributos do bloco
            On Error Resume Next
            Dim Atts As Variant
            Atts = AcadBlock.GetAttributes
            If Err.Number = 0 And Not IsEmpty(Atts) Then
                Debug.Print Now & ": Processando bloco no ModelSpace: " & AcadBlock.Name
                
                Dim j As Long
                For j = LBound(Atts) To UBound(Atts)
                    Set AcadAtt = Atts(j)
                    
                    ' Verifica rapidamente se o atributo tem conteúdo
                    If Not IsEmpty(AcadAtt.TextString) And Trim(AcadAtt.TextString) <> "" Then
                        ' Cria chave única para o atributo
                        Dim AttributeKey As String
                        AttributeKey = AcadBlock.Name & "|" & AcadAtt.TagString & "|" & AcadAtt.TextString
                        
                        ' Verifica se já processamos este atributo
                        If Not UniqueAttributes.Exists(AttributeKey) Then
                            UniqueAttributes.Add AttributeKey, True
                            
                            ExcelSheet.Cells(Row, 1).Value = AcadBlock.Name
                            ExcelSheet.Cells(Row, 2).Value = AcadAtt.TagString
                            ExcelSheet.Cells(Row, 3).Value = AcadAtt.TextString
                            
                            Debug.Print Now & ": Novo atributo único encontrado: " & AttributeKey
                            Row = Row + 1
                        Else
                            Debug.Print Now & ": Atributo duplicado ignorado: " & AttributeKey
                        End If
                    End If
                Next j
            End If
            On Error GoTo 0
        Next AcadBlock
        
        ' Processa PaperSpace
        Debug.Print Now & ": Iniciando processamento do PaperSpace"
        For Each AcadBlock In AcadDoc.PaperSpace
            ' Tenta obter atributos do bloco
            On Error Resume Next
            Dim AttsPS As Variant
            AttsPS = AcadBlock.GetAttributes
            If Err.Number = 0 And Not IsEmpty(AttsPS) Then
                Debug.Print Now & ": Processando bloco no PaperSpace: " & AcadBlock.Name
                
                Dim k As Long
                For k = LBound(AttsPS) To UBound(AttsPS)
                    Set AcadAtt = AttsPS(k)
                    
                    ' Verifica rapidamente se o atributo tem conteúdo
                    If Not IsEmpty(AcadAtt.TextString) And Trim(AcadAtt.TextString) <> "" Then
                        ' Cria chave única para o atributo
                        AttributeKey = AcadBlock.Name & "|" & AcadAtt.TagString & "|" & AcadAtt.TextString
                        
                        ' Verifica se já processamos este atributo
                        If Not UniqueAttributes.Exists(AttributeKey) Then
                            UniqueAttributes.Add AttributeKey, True
                            
                            ExcelSheet.Cells(Row, 1).Value = AcadBlock.Name
                            ExcelSheet.Cells(Row, 2).Value = AcadAtt.TagString
                            ExcelSheet.Cells(Row, 3).Value = AcadAtt.TextString
                            
                            Debug.Print Now & ": Novo atributo único encontrado: " & AttributeKey
                            Row = Row + 1
                        Else
                            Debug.Print Now & ": Atributo duplicado ignorado: " & AttributeKey
                        End If
                    End If
                Next k
            End If
            On Error GoTo 0
        Next AcadBlock
        
        Debug.Print Now & ": Total de atributos únicos no arquivo: " & UniqueAttributes.Count
        
        ExcelSheet.Cells(Row, 1).Value = "Fim do Arquivo: " & FileNames(i)
        Row = Row + 2
        AcadDoc.Close False
    Next i
    
    ' Formata a planilha
    With ExcelSheet.Range("A1:C1")
        .Font.Bold = True
        .Interior.ColorIndex = 15
    End With
    ExcelSheet.Columns("A:C").AutoFit
    Application.ScreenUpdating = True
    Debug.Print Now & ": Planilha formatada."

    ' Fecha o AutoCAD
    Debug.Print Now & ": Fechando o AutoCAD."
    AcadApp.Quit
    
    ' Limpa objetos
    Set UniqueAttributes = Nothing
    Set AcadAtt = Nothing
    Set AcadBlock = Nothing
    Set AcadDoc = Nothing
    Set AcadApp = Nothing
    
    MsgBox "Exportação concluída! Foram processadas " & (Row - 2) & " linhas.", vbInformation
    Debug.Print Now & ": Exportação concluída."
    Debug.Print "--------------------------------------- Fim do Debug ----------------------------------------"
End Sub

' Função para verificar se o AutoCAD está em execução (mantida sem alterações)
Private Function ProcessExist(ProcessName As String) As Boolean
    Dim objWMIService As Object
    Dim colProcesses As Object
    
    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
    Set colProcesses = objWMIService.ExecQuery("Select * from Win32_Process Where Name = '" & ProcessName & "'")
    
    ProcessExist = (colProcesses.Count > 0)
    
    Set colProcesses = Nothing
    Set objWMIService = Nothing
End Function

' Função de espera (mantida sem alterações)
Private Sub Wait(Seconds As Long)
    Dim EndTime As Date
    EndTime = DateAdd("s", Seconds, Now)
    Do While Now < EndTime
        DoEvents
    Loop
End Sub

Edited: Now I checked if is there empty attributes before running the loop and repeated attributes will be placed once.

[ed57gmc]

First, how are you running this script? In Excel as VBA? As an exe? I ask since your use of process detection is confusing, because you also try to create an instance of AutoCAD. What is your reason for selecting your choice. I would probably run it as and AutoCAD VBA and export to xl.

[Telles0808]

This is a much more advanced script than simply opening AutoCAD and run a VBA to export data to Excel. It opens multiple AutoCAD files, searches for any blocks with attributes, and then exports that information to Excel. Additionally, the script optimizes resource usage, ensuring efficiency and minimizing system strain during execution.

In Excel, I will build dynamic tables to select the information as needed, allowing me to filter drawings with issues, such as problems with stamps, for example, and perform quick, batch checks on multiple projects, making it easier to analyze and identify inconsistencies efficiently.

[ed57gmc]

That info might be interesting, but you didn't answer my question. How are you running this code? As VBA in some app? Which app? VB.Net? Or something else? It happens to make a difference.

[Telles0808]

excel, it´s on first post and topic name

[ed57gmc]

Even though you mentioned Excel, from your code, it's not clear that you are running VBA from within Excel. Because you are opening multiple sessions of ACAD, you are complicating the process. Use my GetAcad() function to replace lines 15-47 in your code. Just open acad once and then using the Documents collection, open a file one at a time and close it when finished with it. Then finally close acad.

[Telles0808]

Why would I want to open the CAD interface and interact with it one by one when I can automate the process for multiple files?

I couldn't understand where it can help me export the data to excel like I wanted. To improve a bit the script, I'm working to export only the desired attributes of a specific block now.

[ed57gmc]

I didn’t suggest that. When you open a new instance of the application, it uses a lot of resources and is slow. What I suggested was to open the application once and use the AcadApplication.Documents collection api to open documents programmatically. If you’re not doing anything that requires graphics, you can use ObjectDBX api to open files in the background. It’s very fast. Search this forum for AxDbDocument. I just retired. I don’t have acce to acad via right now or I would write you a sample. But there’s plenty of code samples in this forum.