Grab Attribute Data from Dwg Files in a Folder

This example will let user select a folder that contains dwg files. It then opens each drawing and extracts attribute data from all the blocks. The data is then put in an excel table. The table is then sorted according to the y coordinate insertion point of each block.

For this example I have a folder of dwg files where each dwg file has blocks called ‘bom_title2′ and bom_title3’ and I want to extract the attributes from these blocks.

For the code to work, it needs to be pasted into an excel vba module. Then a button can be made with the macro ‘PlotThisDirectory’

If you ever have to hand type data into an excel file. This process will save days you would spend hand typing the data

block named ‘bom_title2’
block named ‘bom_title3’
Option Explicit
Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
End Function
Public Sub PlotThisDirectory()
    Dim acadApp As Object
    Dim acadDoc As Object
    Dim BBarray() As Variant
    Dim BlkAtts As Variant
    Dim blknm As AcadBlockReference
    Dim CurrentFile As String
    Dim effName As String
    Dim FilterData() As Variant
    Dim FilterType() As Integer
    Dim i As Long
    Dim lastcolumn As Long
    Dim lastrow As Long
    Dim Nrows As Long
    Dim objInSelect As Variant
    Dim oSset As AcadSelectionSet
    Dim Path As String
    Dim rowBB As Long
    ReDim BBarray(1 To 2000, 1 To 16)
    ReDim FilterType(3)
    ReDim FilterData(3)
    On Error Resume Next
    'get the autodesk app
    Set acadApp = GetObject(, "AutoCAD.Application")
    acadApp.Visible = True
    If acadApp Is Nothing Then
        Set acadApp = CreateObject("AutoCAD.Application")
        acadApp.Visible = True
    End If
    If acadApp Is Nothing Then
        MsgBox "Sorry, it was impossible to get AutoCAD!", vbCritical, "AutoCAD Error"
        Exit Sub
    End If
    On Error GoTo 0
    acadApp.WindowState = acMax
    'let the user specify the folder path with the function GetFolder
    Path = GetFolder() & "\"
    CurrentFile = Dir(Path + "*.dwg", vbNormal)
    'loop through all the files
    rowBB = 1
    Do While CurrentFile <> ""
        acadApp.Documents.Open Path + CurrentFile, False
        Set acadDoc = acadApp.ActiveDocument
        acadDoc.ActiveSpace = acModelSpace
        'create a Filter List Conditions ,see
        FilterType(0) = -4
        FilterType(1) = 67
        FilterType(2) = 0
        FilterType(3) = -4
        FilterData(0) = "<and"
        FilterData(1) = 0
        FilterData(2) = "INSERT"
        FilterData(3) = "and>"
        'create the selections set
        Set oSset = acadDoc.SelectionSets.Add("SS5")
        oSset.Select acSelectionSetAll, , , FilterType, FilterData
        rowBB = rowBB + 2
        BBarray(rowBB, 1) = CurrentFile
        rowBB = rowBB + 2
        On Error Resume Next
        For Each objInSelect In oSset
            Set blknm = objInSelect
            effName = objInSelect.Name
            Select Case effName
                Case "bom_title3"  'add as many cases as neeed that includes the block name
                    BlkAtts = objInSelect.GetAttributes
                    For i = 0 To UBound(BlkAtts)
                        BBarray(rowBB, i + 2) = BlkAtts(i).TextString
                    Next i
                    BBarray(rowBB, 16) = blknm.InsertionPoint(1)
                    rowBB = rowBB + 1
                Case "bom_title2"
                    BlkAtts = objInSelect.GetAttributes
                    For i = 0 To UBound(BlkAtts)
                        BBarray(rowBB, i + 2) = BlkAtts(i).TextString
                    Next i
                    BBarray(rowBB, 16) = blknm.InsertionPoint(1)
                    rowBB = rowBB + 1
            End Select
            effName = ""
        Next objInSelect
        On Error GoTo 0
        acadDoc.Close False
        CurrentFile = Dir
    Nrows = UBound(BBarray, 1) - LBound(BBarray, 1)  'find are large the array is
    With Sheet1
        'clear the existing data
        On Error Resume Next
        lastcolumn = .Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
        lastrow = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        On Error GoTo 0
        If lastrow > 17 And lastcolumn > 0 Then
            .Range(.Cells(18, 1), .Cells(lastrow, lastcolumn)).Clear
        End If
        'place the array of data into the sheet
        .Range(.Cells(18, 1), .Cells(18 + Nrows, 16)) = BBarray
    End With
    Call sort_the_data
End Sub
Sub sort_the_data()
'sort the data according the y coordinate of the insertion point
'will only sort within each separate drawing
    Application.ScreenUpdating = False
    With Sheet1
        Dim truelastrow As Long
        Dim lastrow As Long
        Dim startrow As Long
        Dim loopcounter As Long
        truelastrow = .Cells(Rows.Count, "p").End(xlUp).Row
        startrow = 22
        loopcounter = 1
        Do Until lastrow > truelastrow
            lastrow = .Cells(startrow, "a").End(xlDown).Row - 3
            .Sort.SortFields.Add2 Key:=.Cells(lastrow, "p"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            With .Sort
                .SetRange Range(Cells(startrow, "a"), Cells(lastrow, "p"))
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
            End With
            startrow = lastrow + 5
        truelastrow = .Cells(Rows.Count, "p").End(xlUp).Row
        Range(Cells(22, "p"), Cells(truelastrow, "p")).Clear
    End With
    Application.ScreenUpdating = True
End Sub

2 thoughts on “Grab Attribute Data from Dwg Files in a Folder”

  1. Hi, love the tool, I am getting a subscript out of range error when I hit about 30-40 drawings, I think the array is growing too large before the data is pasted? Do you have any ideas or a solution to this?


Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s