How to export Block information and Block Attribute to Excel with VBA?

[klpocska]

I have a lot of Block with attribute. I want to store the Block information and the block attribute into an excel sheet by VBA.

 

What should I do ?

[fixo]

I have a lot of Block with attribute. I want to store the Block information and the block attribute into an excel sheet by VBA.

 

What should I do ?

 

This will get you started

Author unknown

 

 

'' Request reference to Microsoft Excel XX.0 Object Library
Option Explicit

Public Sub WriteAttributes()

Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim oBlkRef As AcadBlockReference
Dim oAtt As AcadAttributeReference
Dim varAtt As Variant
Dim i As Long
Dim ftype(1) As Integer
Dim fdata(1) As Variant
ftype(0) = 0: fdata(0) = "INSERT"
ftype(1) = 66: fdata(1) = 1
Dim dxftype As Variant
Dim dxfdata As Variant
dxftype = ftype
dxfdata = fdata
'---------------------
Dim xlApp As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim lngRow As Long, lngCol As Long

'---------------------
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set xlApp = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Impossible to initialize an Excel.", vbExclamation
End
End If
End If
'---------------------

On Error Resume Next
Set oSset = ThisDrawing.SelectionSets.Item("$Attribs$")
If Err Then
Err.Clear
Set oSset = ThisDrawing.SelectionSets.Add("$Attribs$")
End If

On Error GoTo Err_Control

oSset.SelectOnScreen dxftype, dxfdata
'---------------------
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Add
xlBook.Sheets.Add.Name = 1
Set xlSheet = xlBook.Sheets(1)
lngRow = 1
xlSheet.Cells(lngRow, 1).Value = "Block Name"
xlSheet.Rows(1).Font.Bold = True
xlSheet.Rows(1).Font.ColorIndex = 5
'---------------------
lngRow = 2
For Each oEnt In oSset

Set oBlkRef = oEnt
If oBlkRef.IsDynamicBlock Then
xlSheet.Cells(lngRow, 1).Value = oBlkRef.EffectiveName
Else
xlSheet.Cells(lngRow, 1).Value = oBlkRef.Name
End If
varAtt = oBlkRef.GetAttributes
lngCol = 2
For i = 0 To UBound(varAtt)
Set oAtt = varAtt(i)
xlSheet.Cells(lngRow, lngCol).Value = oAtt.TagString
xlSheet.Cells(lngRow + 1, lngCol).Value = oAtt.TextString
lngCol = lngCol + 1

Next i

lngRow = lngRow + 2

Next oEnt
'--------------------
Dim oRange As Range
Set oRange = xlSheet.UsedRange
For i = 2 To oRange.Columns.Count
xlSheet.Cells(1, i).Value = "Attribue " & CStr(i - 1)
Next
'--------------------
xlSheet.Columns.HorizontalAlignment = xlHAlignLeft
xlSheet.Columns.AutoFit
xlBook.SaveAs ThisDrawing.Path & "\Attributes.xls"
xlBook.Close
'--------------------
xlApp.Application.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
'--------------------
MsgBox "Excel file was saved as: " & vbCr & ThisDrawing.Path & "\Attributes.xls"
'--------------------
Err_Control:

End Sub

 

~'J'~