Extract attributes by specific block name

[Anonymous]

Hi everybody. Im new to VBA in autocad and im trying to extract the attributes of specific block to Excel. The block is a drawing header and the name of it is "A1 - NME".

I found the code below on the internet and it work very well, except it extracts all blocks with attributes in the drawing. Is it possible to change the code so it only extracts blocks with the name "A1 - NME"?

Option Explicit
Sub Extract()
   If ThisDrawing Is Nothing Then
       MsgBox "Please open a drawing file and then restart this macro."
       Exit Sub
   End If

   '-------------------------------------------------------
   'Excel setup

   Dim Excel As Application
   Dim MySheet As Excel.Worksheet
   Dim BlckNameRng As Excel.Range, TagsRng As Excel.Range, myCell As Excel.Range
   Dim iniColStr As String
   Dim iniRow As Long, iniCol As Long

   ' handling excel application
   On Error Resume Next
   Set Excel = GetObject(, "Excel.Application")
   If Err Then Set Excel = CreateObject("Excel.Application")

   ' handling workbook and worksheet
   With Excel
       .Visible = True
       Set MySheet = .ActiveWorkbook.ActiveSheet
       If Err Then
           .Workbooks.Add
           Set MySheet = .ActiveWorkbook.ActiveSheet
       End If
       On Error GoTo 0
   End With

   'handling columns where to start writing data from
   iniColStr = "J"    '<-- Here you specify which column to start writing data from
   iniRow = 1          '<-- Here you specify which row to start writing data from
   iniCol = MySheet.Range(iniColStr & "1").Column
   Set BlckNameRng = MySheet.Cells(iniRow, iniCol).Resize(, 1000) ' this will clear excel cells in 1000 columns right of the initial one
   Set TagsRng = BlckNameRng.Offset(1)
   With BlckNameRng
       .EntireColumn.Clear
       With .Font
           .Bold = True
           .color = 1152
       End With
   End With
   '-------------------------------------------------------


   '-------------------------------------------------------
   'blocks reference searching&handling

   Dim myBlckRef As AcadBlockReference
   Dim Attrs As Variant
   Dim nBlckRefs As Integer, iBlckRef As Integer, nAttrs As Integer, iAttr As Integer, nTags As Integer
   Dim BlckName As String, BlckHandle As String

   Dim gpCode(0) As Integer
   Dim dataValue(0) As Variant
   Dim ssetObj As AcadSelectionSet

   Dim myRow As Long, myCol As Long
   Dim LBnd As Integer, Ubnd As Integer

   'selecting block references in the active drawing
   gpCode(0) = 0
   dataValue(0) = "INSERT"
   On Error Resume Next
   Set ssetObj = ThisDrawing.SelectionSets.Add("BlockRefSset")
   If Err <> 0 Then
       Set ssetObj = ThisDrawing.SelectionSets.Item("BlockRefSset")
   Else
       ssetObj.Clear
   End If
   On Error GoTo 0
   ssetObj.Select acSelectionSetAll, , , gpCode, dataValue
   'handling block references found
   nTags = 0 ' this counter will keep track of the number of columns filled with blockreferences data ("handles" and "attributes")
   nBlckRefs = ssetObj.Count
   
   
   For iBlckRef = 0 To nBlckRefs - 1
       Set myBlckRef = ssetObj.Item(iBlckRef)
       If myBlckRef.HasAttributes Then

           ' getting blockreference info
           With myBlckRef
               BlckName = .Name
               BlckHandle = .Handle
               Attrs = .GetAttributes
           End With
           LBnd = LBound(Attrs)
           Ubnd = UBound(Attrs)
           nAttrs = Ubnd - LBnd + 1

           ' handling excel list structure consequent to blockreference blockname
           Set myCell = BlckNameRng.Find(BlckName, lookin:=xlValues) ' searching for blockname existence
           If myCell Is Nothing Then 'if the blockname hasn't already been met-> registered

               'then we have to arrange new columns to house blockreference data (handle and attributes tagstrings and textstrings)

               myCol = nTags + 1 ' setting ref column (where to start writing from) one to the right of the last one
               nTags = nTags + 1 + nAttrs ' update number of columns to be filled with data: the "1" is for the "handle" column

               ' writing block header cells
               With BlckNameRng(1, myCol)
                   .Value = BlckName
                   With .Resize(, nAttrs + 1)
                       .Merge
                       .BorderAround (xlContinuous)
                       .HorizontalAlignment = xlCenter
                   End With
               End With

               ' writing blockreference data header cells (handle and attributes tags)
               With TagsRng(1, myCol)
                   .Value = "HANDLE"
                   .BorderAround (xlContinuous) 'every block data heade is boxed
                   For iAttr = LBnd To Ubnd
                       With .Offset(0, 1 + iAttr - LBnd)
                           .Value = Attrs(iAttr).TagString
                           .BorderAround (xlContinuous)
                           .HorizontalAlignment = xlCenter
                       End With
                   Next iAttr
               End With

           Else
               ' if the blockname has already been listed
               myCol = myCell.Column - BlckNameRng.Column + 1 'set ref column to the found cell one
           End If

           'writing blockreference data cells
           With BlckNameRng.Offset(, myCol - 1).EntireColumn
               myRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row ' getting the first free cell in the column
               With .Cells(myRow, 1)
                   .Borders(xlEdgeLeft).LineStyle = xlContinuous ' left border the 1st column
                   .Value = BlckHandle ' writing handle data
                   For iAttr = LBnd To Ubnd
                       .Offset(0, 1 + iAttr - LBnd).Value = Attrs(iAttr).TextString ' writing attributes string data
                   Next iAttr
                   .Offset(0, 1 + Ubnd - LBnd).Borders(xlEdgeRight).LineStyle = xlContinuous ' right border the last column
               End With
           End With

       End If
   Next iBlckRef
   '-------------------------------------------------------
   With BlckNameRng.CurrentRegion
       .Columns.AutoFit
       .Select
   End With
   Set Excel = Nothing
End Sub

[Ed__Jobe · Accepted solution]

Yes, its possible using selectionset filters. Your code does this after the comment 'Selecting block references in the active drawing. See this thread for how to work with filters.

[norman.yuan]

The code is very messy and very poorly structured, but since you are new to coding, I only hope you to learn organize the code in better way sooner: break down it into small chunks as Function/Sub with each one does one thing: identifying target block reference; retrieving attribute data from the block reference; connecting running Excel app; identifying sheet range; fill attribute data in the target sheet range; ...

Now directly to your question. You can add block name to the selectionset filter, as @Ed__Jobe suggested. However, if the block reference (you say it is drawing header, maybe it is "title block", as commonly called) is a dynamic block, using block name as selectionset filter would not work. Considering you are new, and the current code works, you only need to make a very simple and straightforward change (in red)

   For iBlckRef = 0 To nBlckRefs - 1
       Set myBlckRef = ssetObj.Item(iBlckRef)
       '' You simply test the block's name (EffectiveName)
       '' Obviously, you may not want to hard-code the block 
       '' name later, after you learned more on programming
       If UCase(myBlckRef.EffectiveName) = "A1 - NME" Then
           If myBlckRef.HasAttributes Then
             ... ...
             ... ...
           End If
           '' if you are sure only one instance of the block in the drawing
           '' you can jump out of the "For...Next" loop to save a tiny bit of time
           Exit For 
       End If
   Next  
   ... ...

[Anonymous]

Yeah I agree, its very messy and not intuitive. The blocks are not are not dynamic so the other solution worked, but thank you for the answer.

[Anonymous]

hi

i seen your rconversation.

could u share the vba. i like to extarct selected tittle block tag details to excel from multiple cad files.

thx

[grobnik]

@Anonymous 

Hi Do you need support in which section ?

Open multiple files ?

Selecting a block named "XXXX" and extract attributes ?

Transfer attribute to excel ?

For iBlckRef = 0 To nBlckRefs - 1
       Set myBlckRef = ssetObj.Item(iBlckRef)
       '' You simply test the block's name (EffectiveName)
       '' Obviously, you may not want to hard-code the block 
       '' name later, after you learned more on programming
       If UCase(myBlckRef.EffectiveName) = "A1 - NME" Then ' place here your block name
           If myBlckRef.HasAttributes Then
             MyAttributes=myBlckRef.getattributes
             For X=Lbound(MyAttributes) to Ubound(MyAttributes)
                 MySheet.Range("A" & x+1)=MyAttributes(X).TagString
                 MySheet.Range("B" & x+1)=MyAttributes(X).TextString
             Next
           End If
           '' if you are sure only one instance of the block in the drawing
           '' you can jump out of the "For...Next" loop to save a tiny bit of time
           Exit For 
       End If
   Next  

Above a simple test which transfer all selected blocks attributes prompt and value.

If you know the exactly position in the MyAttributes array created, related to attribute to check or extract you can add an additional control such as:

 MyAttributes=myBlckRef.getattributes
             MyAttpos=0 ' place here the position of attribute to check
             MyRow=1
             MySheet.Range("A" & MyRow)=MyAttributes(MyAttpos).TagString
             MySheet.Range("B" & MyRow)=MyAttributes(MyAttpos).TextString
             ' if you have more attributes you can increase MyRow value

The above macro shall be integrated with selection set indicated into the main macro showed in the first post

 'selecting block references in the active drawing
   gpCode(0) = 0
   dataValue(0) = "INSERT"
   On Error Resume Next
   Set ssetObj = ThisDrawing.SelectionSets.Add("BlockRefSset")
   If Err <> 0 Then
       Set ssetObj = ThisDrawing.SelectionSets.Item("BlockRefSset")
   Else
       ssetObj.Clear
   End If
   On Error GoTo 0
   ssetObj.Select acSelectionSetAll, , , gpCode, dataValue

Macro could be more or less easy, it will depend if have to do the extraction just one time or it will be repeated more than one time on a group of file.

Hope all above could helps you more.