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
Solved! Go to Solution.
Solved by Telles0808. Go to Solution.
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
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.
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.
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.
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.
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.
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.
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.
Can't find what you're looking for? Ask the community or share your knowledge.