vba实现CAD与excel交互功能可提高工作效率,此例可供参考。
如果无法加载工程文件,需:开始-运行---输入regsvr32.exe FM20.dll,点确定即可。
引用库文件路径如下图(不是必须):
上图是未引用状态,引用后如下:
(版本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