[编程交流] 如何导出区块信息

'' 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