Extracting specific blocks with attributes

December 19, 2013

Hello,

I have this excel macro that extracts blocks with attributes from an open acad dwg into an excel spreadsheet.

I need your help to modify this code to be able to do this:

-specify in the line code the name of the blocks I want to extract

-specify in what columns each block will be extracted.

I use AutoCAD 2011 and excel 2010

Bellow is the excel VBA code.

Thank you for your help.

Public acad As Object
Public mspace As Object
Public excel As Object
Public AcadRunning As Integer
Public excelSheet As Object
Sub Extract()
   Dim sheet As Object
   Dim shapes As Object
   Dim elem As Object
   Dim excel As Object
   Dim Max As Integer
   Dim Min As Integer
   Dim NoOfIndices As Integer
   Dim excelSheet As Object
   Dim RowNum As Integer
   Dim Array1 As Variant
   Dim Count As Integer
    
   Set excel = GetObject(, "Excel.Application")
   Set excelSheet = excel.ActiveWorkbook.ActiveSheet
   excelSheet.Range(Cells(1, 1), Cells(45, ).Clear
   excelSheet.Range(Cells(1, 1), Cells(1, ).Font.Bold = True
   excelSheet.Range(Cells(1, 1), Cells(1, ).Font.Color = 1152
       Set acad = Nothing
   On Error Resume Next
   Set acad = GetObject(, "AutoCAD.Application")
   If Err <> 0 Then
       Set acad = CreateObject("AutoCAD.Application")
       acad.Visible = True
       MsgBox "Please open a drawing file and then restart this macro."
       Exit Sub
   End If
   Set doc = acad.ActiveDocument
   Set mspace = doc.ModelSpace
   RowNum = 1
   Dim Header As Boolean
   Header = False
   For Each elem In mspace
       With elem
           If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
               If .HasAttributes Then
                   Array1 = .GetAttributes
                   For Count = LBound(Array1) To UBound(Array1)
                       If Header = False Then
                           If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                               excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
                           End If
                       End If
                   Next Count
                   RowNum = RowNum + 1
                   For Count = LBound(Array1) To UBound(Array1)
                       excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                   Next Count
                   Header = True
               End If
           End If
       End With
   Next elem
   NumberOfAttributes = RowNum - 1
   If NumberOfAttributes > 0 Then
      ActiveWorkbook.ActiveSheet.Range("A1").Sort _
       key1:=ActiveWorkbook.ActiveSheet.Columns("A"), _
       Header:=xlGuess
   Else
       MsgBox "No attributes found in the current drawing."
   End If
   Set acad = Nothing
End Sub


Private Sub Auto_Close()
   Set excelSheet = Nothing
End Sub

December 19, 2013

You need to dig a bit deeper here (.EntityName, "AcDbBlockReference", 1) this returns yes its a block, then you would add another if, is it = to my blockname in a looping list for desired blocks.

maybe selection set generated directly as a group of 1 block objects.

FilterDXFCode(0) = 0
FilterDXFVal(0) = "INSERT"
FilterDXFCode(1) = 2
FilterDXFVal(1) = "DA1DRTXT"
BLOCK_NAME = "DA1DRTXT"
Set SS = ThisDrawing.SelectionSets.Add("issued")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal

For Cntr = 0 To SS.Count - 1
  attribs = SS.Item(Cntr).GetAttributes

attribval1 = attribs(1).TextString

December 20, 2013

Hello,

I have this excel macro that extracts blocks with attributes from an open acad dwg into an excel spreadsheet.

I need your help to modify this code to be able to do this:

-specify in the line code the name of the blocks I want to extract

-specify in what columns each block will be extracted.

I use AutoCAD 2011 and excel 2010

Bellow is the excel VBA code.

Thank you for your help.

Public acad As Object
Public mspace As Object
Public excel As Object
Public AcadRunning As Integer
Public excelSheet As Object
Sub Extract()
   Dim sheet As Object
   Dim shapes As Object
   Dim elem As Object
   Dim excel As Object
   Dim Max As Integer
   Dim Min As Integer
   Dim NoOfIndices As Integer
   Dim excelSheet As Object
   Dim RowNum As Integer
   Dim Array1 As Variant
   Dim Count As Integer

   Set excel = GetObject(, "Excel.Application")
   Set excelSheet = excel.ActiveWorkbook.ActiveSheet
   excelSheet.Range(Cells(1, 1), Cells(45, ).Clear
   excelSheet.Range(Cells(1, 1), Cells(1, ).Font.Bold = True
   excelSheet.Range(Cells(1, 1), Cells(1, ).Font.Color = 1152
       Set acad = Nothing
   On Error Resume Next
   Set acad = GetObject(, "AutoCAD.Application")
   If Err <> 0 Then
       Set acad = CreateObject("AutoCAD.Application")
       acad.Visible = True
       MsgBox "Please open a drawing file and then restart this macro."
       Exit Sub
   End If
   Set doc = acad.ActiveDocument
   Set mspace = doc.ModelSpace
   RowNum = 1
   Dim Header As Boolean
   Header = False
   For Each elem In mspace
       With elem
           If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
               If .HasAttributes Then
                   Array1 = .GetAttributes
                   For Count = LBound(Array1) To UBound(Array1)
                       If Header = False Then
                           If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                               excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
                           End If
                       End If
                   Next Count
                   RowNum = RowNum + 1
                   For Count = LBound(Array1) To UBound(Array1)
                       excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                   Next Count
                   Header = True
               End If
           End If
       End With
   Next elem
   NumberOfAttributes = RowNum - 1
   If NumberOfAttributes > 0 Then
      ActiveWorkbook.ActiveSheet.Range("A1").Sort _
       key1:=ActiveWorkbook.ActiveSheet.Columns("A"), _
       Header:=xlGuess
   Else
       MsgBox "No attributes found in the current drawing."
   End If
   Set acad = Nothing
End Sub


Private Sub Auto_Close()
   Set excelSheet = Nothing
End Sub

as for the excel coding, it actually seems fit to list a single blockname occurrence but you'd better post an example of what are you actual needs in terms of blocks listing.

if I get it well, you'd like to list all references of every different block names in different columns groups. if so, every list structure is strictly connected to the number of tags of every block, which most probably differ from one another. so it could be more effective to set and use a different sheet for every block to be processed.

let me know.

in the meanwhile I think you should do at least the following changes

1)

    Set excelSheet = Excel.ActiveWorkbook.ActiveSheet
   With excelSheet
       .Range(.Cells(1, 1), .Cells(45, ).Clear
       .Range(.Cells(1, 1), .Cells(1, ).Font.Bold = True
       .Range(.Cells(1, 1), .Cells(1, ).Font.color = 1152
   End With

to make the code run

2)

                    For Count = LBound(Array1) To UBound(Array1)
                       excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                   Next Count

and 3)

    If NumberOfAttributes > 0 Then
      excelSheet.Range("A1").Sort _
       key1:=excelSheet.Columns("A"), _
       Header:=xlGuess
   Else

both only to have a consequent usage of variables you correctly set at the beginning

4)

                If .HasAttributes Then
                   Array1 = .GetAttributes
                   If Header = False Then
                       For Count = LBound(Array1) To UBound(Array1)
                           If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                               excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
                           End If
                       Next Count
                       Header = True
                   End If
                   RowNum = RowNum + 1
                   For Count = LBound(Array1) To UBound(Array1)
                       excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                   Next Count
               End If

to avoid unuseful checkings once you process the tagstring.

of course all what above is to be rewritten to match both Bigal suggestion and, if the case, the one-sheet-for-every-blockname setup

December 20, 2013

Thank you so much for your reply.

I have applied your suggestions into the code, and I feel it is running smoother than before , but still I don’t have the ability to manipulate data. I followed your suggestion and I created a small EXCEL example of data:

1. data extraction will start with column BA

2. Col BA & BB correspond to attributes from Block1

3. Col BC & BD correspond to attributes from Block2

4. Col Be corresponds to attributes from Block3 and … so on.

Is there a way to declare what blocks/attributes to be extracted and where?

Thank you for your help and time you put in.

EXCEL block listing.xlsx

December 22, 2013

Thank you so much for your reply.
I have applied your suggestions into the code, and I feel it is running smoother than before , but still I don’t have the ability to manipulate data. I followed your suggestion and I created a small EXCEL example of data:

1. data extraction will start with column BA

2. Col BA & BB correspond to attributes from Block1

3. Col BC & BD correspond to attributes from Block2

4. Col Be corresponds to attributes from Block3 and … so on.

Is there a way to declare what blocks/attributes to be extracted and where?

Thank you for your help and time you put in.

Sure there is! Tomorrow I'll spend some time and let you have a code that will allow you to "dig deeper" and reach your goal.

December 23, 2013

Sure there is! Tomorrow I'll spend some time and let you have a code that will allow you to "dig deeper" and reach your goal.

this the vba listing

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
           .ActiveWorkbook.Worksheets.Add
           Set MySheet = .ActiveWorkbook.ActiveSheet
       End If
       On Error GoTo 0
   End With

   'handling columns where to start writing data from
   iniColStr = "BA"    '<-- Here you specify which column to start writing data from
   iniRow = 2          '<-- 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

it works with W7-32bit, Acad2010 and Excel 2010, establishing references to:

- Visual Basic for Application

- Autocad 2011 type library (!!)

- Microsoft Excel 14.0 Object Library

I wrote it from scratch, but you'll find commented codelines so as you can go on your way and make all changes you need.

December 23, 2013

Hello RICVBA

I am really impressed with the amount of work you put into this code and honestly I am speechless. I embedded this code into my EXCEL spreadsheet but when I try to run the macro I have a message of error "variable not defined". Do you think windows 7-64 bit has something to do with this?

Thank you

December 23, 2013

Hello RICVBA
I am really impressed with the amount of work you put into this code and honestly I am speechless. I embedded this code into my EXCEL spreadsheet but when I try to run the macro I have a message of error "variable not defined". Do you think windows 7-64 bit has something to do with this?

Thank you

tazzzz, I wrote the vba code from Autocad "perspective". i.e.: you have to open VBA IDE in Autocad (not in Excel), insert a Module and paste the code into its code window, and debug it. don't forget to make sure you have set proper references.

after that, 32-64 bit issues could apply. But I hope this will not happen, since I wouldn't be able to support you.

December 23, 2013

Thank you so much for your clarification. If there will be an issue with 64bit I will find a way to go around.

Sign In

Extracting specific blocks with attributes

Recommended Posts

tazzzz

BIGAL

RICVBA

tazzzz

RICVBA

RICVBA

tazzzz

RICVBA

tazzzz

Join the conversation

Tutorials

Forums

Activity