vba实现CAD块属性导出到excel中

vba实现CAD与excel交互功能可提高工作效率，此例可供参考。

如果无法加载工程文件，需：开始-运行---输入regsvr32.exe FM20.dll，点确定即可。

引用库文件路径如下图(不是必须)：

上图是未引用状态，引用后如下：

1. 

（版本1：针对图中只有一种类型的块）代码如下：

Sub 导出块属性到excel()
    Dim Excel As Object
    Dim elem As Object
    Dim excelSheet As Object
    Dim Array1 As Variant
    Dim Count, RowNum As Integer
    Dim NumberOfAttributes As Integer
    
    ' Start Excel
    On Error Resume Next
    
    Set Excel = GetObject(, "Excel.Application")
    
    If Err <> 0 Then
        Err.Clear
        Set Excel = CreateObject("Excel.Application")
            
        If Err <> 0 Then
            MsgBox "Could not load Excel.", vbExclamation
            End
        End If
    End If
    
    On Error GoTo 0
    
    Excel.Visible = True
    Excel.Workbooks.Add
    Excel.Sheets("Sheet1").Select
    Set excelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
    
    RowNum = 1
    Dim Header As Boolean
    For Each elem In ThisDrawing.ModelSpace
        If StrComp(elem.EntityName, "AcDbBlockReference", 1) = 0 Then
            If elem.HasAttributes Then
                Array1 = elem.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
    Next elem
    
    NumberOfAttributes = RowNum - 1
    
    If NumberOfAttributes > 0 Then
        excelSheet.UsedRange.Font.Bold = True
        
        'For a specific set of attribute information this could
        'be set to fit the exact number of columns.
        excelSheet.Columns("A:G").AutoFit

    Else
        MsgBox "未发现有属性的块" & Space(50) & vbCr & _
 "写代码qq:443440204", vbInformation, "版权所有qq:443440204"
        ''Excel.Quit
    End If
MsgBox "OK" & Space(50) & vbCr & _
 "vba代码二次开发qq:443440204", vbInformation, "版权所有qq:443440204"
End Sub

 

（版本2：针对图中只多种类型的块）代码如下： 

Sub 导出块属性到excel()
    Dim Excel As Object
    Dim elem As Object
    Dim excelSheet As Object
    Dim Array1 As Variant
    Dim Count, RowNum As Integer
    Dim NumberOfAttributes As Integer
    
    ' Start Excel
    On Error Resume Next
    
    Set Excel = GetObject(, "Excel.Application")
    
    If Err <> 0 Then
        Err.Clear
        Set Excel = CreateObject("Excel.Application")
            
        If Err <> 0 Then
            MsgBox "Could not load Excel.", vbExclamation
            End
        End If
    End If
    
    On Error GoTo 0
    
    Excel.Visible = True
    Excel.Workbooks.Add
    Excel.Sheets("Sheet1").Select
    Set excelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
    
    RowNum = 1
   
    For Each elem In ThisDrawing.ModelSpace
        If StrComp(elem.EntityName, "AcDbBlockReference", 1) = 0 Then
            If elem.HasAttributes Then
            Stop
 ''通过getattributes函数我们把块的属性放入数组中，下图可见数组有3个项目
 ''每个项目都有tagstring和textstring,然后把数组中值输出到excel，至此
 ''我们提取出了块中的全部属性
                Array1 = elem.GetAttributes
                
                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
                RowNum = RowNum + 1
                For Count = LBound(Array1) To UBound(Array1)
                    excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                Next Count
              
            End If
             RowNum = RowNum + 1
        End If
       
    Next elem
    
    NumberOfAttributes = RowNum - 1
    
    If NumberOfAttributes > 0 Then
        excelSheet.UsedRange.Font.Bold = True
        
        'For a specific set of attribute information this could
        'be set to fit the exact number of columns.
        excelSheet.Columns("A:G").AutoFit

    Else
        MsgBox "未发现有属性的块" & Space(50) & vbCr & _
 "写代码qq:443440204", vbInformation, "版权所有qq:443440204"
        ''Excel.Quit
    End If
MsgBox "OK" & Space(50) & vbCr & _
 "vba代码二次开发qq:443440204", vbInformation, "版权所有qq:443440204"
End Sub