First we need to to list all block names within your drawing.
create a form with a listbox named Listbox1.
when the form is initialized you can call a function to list all block names in your drawing
Option Explicit
Dim blkname As String
Public objSS As AcadSelectionSet
Dim MyBlist() As String
Dim ObjBlockRef As AcadBlockReference
Dim MaxAtt As Integer
Sub UserForm_Initialize()
UserForm1.Caption = "Block attributes to Excel"
Call ListBlocks
End Sub
The following function will create an array (a VBA array) of all the block names in your current drawing, it will also place them into alphabetical order.
Function ListBlocks()
Dim ObjBlk As AcadBlock
Dim MyBlkList() As String
Dim iCounter As Integer
Dim i As Variant
On Error Resume Next
iCounter = 0
For Each ObjBlk In ThisDrawing.Blocks
If Not (ObjBlk.IsXRef) Then
If Left(ObjBlk.Name, 1) <> "*" Then
ReDim Preserve MyBlkList(iCounter)
MyBlkList(iCounter) = ObjBlk.Name
iCounter = iCounter + 1
End If
End If
Next
' sort list order into alphabetical order
SortArray MyBlkList
' place the sorted array list into a ListBox
For i = LBound(MyBlkList) To UBound(MyBlkList)
UserForm1.ListBox1.List() = MyBlkList
Next
End Function
'begin array sort, this will sort the array into alphabetical order
Public Sub SortArray(StringArray() As String)
Dim loopOuter As Integer
Dim loopInner As Integer
Dim i As Integer
For loopOuter = UBound(StringArray) To _
LBound(StringArray) Step -1
For loopInner = 0 To loopOuter - 1
If UCase(StringArray(loopInner)) > _
UCase(StringArray(loopInner + 1)) Then
Swap StringArray(loopInner), _
StringArray(loopInner + 1)
End If
Next loopInner
Next loopOuter
End Sub
Private Sub Swap(a As String, b As String)
Dim c As String: c = a: a = b: b = c
End Sub
'End array sort
Now that you have a listbox containing all your blocks you can now select one to export any attributes to excel
create a command button on the form named CommandButton1
Sub CommandButton1_Click()
'send attribute data to excel
Dim i As Integer
Dim intType(0 To 1) As Integer
Dim varData(0 To 1) As Variant
On Error Resume Next
If Not IsNull(objSS) Then
ThisDrawing.SelectionSets.Item("Export_SelectionSet").Delete
Else
End If
For i = 0 To UserForm1.ListBox1.ListCount
If UserForm1.ListBox1.Selected(i) = True Then
intType(0) = 0
varData(0) = "INSERT"
intType(1) = 2
varData(1) = UserForm1.ListBox1.List(i)
Set objSS = ThisDrawing.SelectionSets.Add("Export_SelectionSet")
objSS.Select acSelectionSetAll, FilterType:=intType, FilterData:=varData
End If
Next i
Call GetAtts
Call Export2Excel
' UnloadDVB This VBA program
' ThisDrawing.SendCommand "_vbaunload" & vbCr & "DVBFILENAME.dvb" & vbCr
End 'ends program closes form
End Sub
The below will get the attribut values for each block (as selected in the list) in the drawing.
Sub GetAtts()
Dim varPick As Variant
Dim objEnt As AcadEntity
Dim varAttribs As Variant
Dim strAttribs As String
Dim BlkCount As Integer
Dim lngI As Integer
Dim iCounter As Integer
On Error Resume Next
iCounter = 0
MaxAtt = 1
BlkCount = objSS.Count
For Each ObjBlockRef In objSS
If ObjBlockRef.HasAttributes Then
'get attributes
varAttribs = ObjBlockRef.GetAttributes
For lngI = LBound(varAttribs) To UBound(varAttribs)
ReDim Preserve MyBlist(BlkCount, MaxAtt + 1)
MyBlist(iCounter, 0) = ObjBlockRef.Name
MyBlist(iCounter, lngI + 1) = varAttribs(lngI).TextString
If UBound(varAttribs) > MaxAtt Then
MaxAtt = UBound(varAttribs)
End If
Next lngI
iCounter = iCounter + 1
End If
Next
End Sub
'The following function sends each block attribute to excel placing it into a cell, a new row is created for each block encountered.
Function Export2Excel()
'export data to Excel
Dim excel As Object 'Excel itself
Dim excelsheet As Object 'the Excel sheet
Dim exapp As Object 'the Excel file
Dim RowNum As Integer
Dim i As Variant
Dim ia As Integer
On Error Resume Next 'prevent stopping if Excel is not open
Set excel = GetObject(, "Excel.application") 'activate Excel if open
If Err <> 0 Then
Set excel = CreateObject("Excel.application") 'Open Excel if not open
End If
excel.Visible = True
Set exapp = excel.Workbooks.Add '("C:\My Documents\Sample.xls") 'open the file
ia = 0
With excel
Set excelsheet = excel.ActiveWorkbook.Sheets("sheet1") 'activate the sheet
excelsheet.Cells(2, ia + 1).Value = "BlockName"
With exapp
RowNum = 3 'start in row 3 (data already exists in rows 1-8 in the formatted file)
For i = LBound(MyBlist, 1) To UBound(MyBlist, 1) 'for the number of lines add the length to a cell
Do While ia < MaxAtt + 2
If MyBlist(i, ia) = "" Then
ia = ia + 1
Else
' send this info to excel spreedsheet
excelsheet.Cells(RowNum, ia + 1).Value = MyBlist(i, ia)
' Debug.Print MyBlist(i, ia)
ia = ia + 1
End If
Loop
RowNum = RowNum + 1 'increment the row number for the next entry
ia = 0
Next
End With
End With
Erase MyBlist
End Function
Ok now that should do the trick.
It's a little crude, as I did not allow for a test to or a bypass if the block you selected does not contain any attributes. It will simply go through the program as if it does. So therefore it will open excel create a blank worksheet.
What you can add or modify is a test so it will not do that and maybe give you a message box saying block does not contain attributes so nothing to do.
The above programming only allows for a single block name. So it is useful for numbered items etc.
once this is done you can then either creat some more pragramming within excel to build a pretty table or you could even add that into the acad vba program, tht way it's all contained in the one program. It's a little trickier as you have do control excel from acad, but can be done without to much trouble.
I hope the above makes sense.
most of that programming is extracts from my Global Attribute editer as posted in the Swamp earlier.