【源代码】一键导出CAD块属性到表格
▎具体需求
使用CAD的人都知道图块，因为图块可以重复插入、做成图库，减少重复操作，被广泛使用。
当图块中有一些文字属性需要经常修改的时候，我们就可以在图块中添加属性文字，并定义成属性块。比如一些图框块，将零散的图元做成块，可以实现批量插入并修改的效果。
有插入就有导出，当我们需要获取属性块中的各个属性内容的时候，挨个获取属性块的信息特别的繁琐，需要打开块属性，手动复制粘贴。
这个时候我们就想到利用程序实现批量读取属性块的内容。
▎思路分析
大概流程：
用户选择一批图元→点击程序按钮，后台循环获取图元的属性。→输出所有属性到excel中。
有几个小细节需要考虑周全。
①获取的块属性个数不一定相同，需要获取所有块属性标题。
②因为块的位置不同，需要根据块的坐标进行排列最终的属性。
程序界面
▎效果及源代码
效果：
代码是在Excel中的，通过excel链接CAD，并且读取属性。
Public Block_Info '存储块属性的坐标及具体数据
Private Sub CommandButton1_Click()
'//导出单个属性
'//开始对属性按坐标排序
Dim Result()
bol = IIf(Me.OptionButton1.Value = True, 2, 1)
Block_Info = ArraySortTwo(Block_Info, bol, SortDESC) '按坐标降序排列的属性数组
col = Getcol(Block_Info, Me.ComboBox1.Value)
For i = 1 To UBound(Block_Info)
k = k + 1
ReDim Preserve Result(1 To 1, 1 To k)
Result(1, k) = Block_Info(i, col)
Next
ActiveCell.Resize(UBound(Result, 2)) = WorksheetFunction.Transpose(Result)
MsgBox "导出完成！"
Unload Me
End Sub
Private Sub CommandButton2_Click()
'//导出所有块属性
'//开始对属性按坐标排序
Dim Result()
bol = IIf(Me.OptionButton1.Value = True, 2, 1)
Block_Info = ArraySortTwo(Block_Info, bol, SortDESC) '按坐标降序排列的属性数组
'ActiveCell.Resize(UBound(Block_Info, 2), UBound(Block_Info, 1)) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Block_Info))
arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Block_Info))
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 2)
For i = 1 To UBound(arr)
For j = 3 To UBound(arr, 2)
brr(i, j - 2) = arr(i, j)
Next
Next
ActiveCell.Resize(UBound(brr), UBound(brr, 2)) = brr
MsgBox "导出完成！"
Unload Me
End Sub
Private Sub UserForm_Initialize()
'//窗体加载初始化事件，有一些必要的错误判断，以及读取块属性到数组中。
Me.OptionButton1.Value = True
Set d_TagStr = CreateObject("scripting.dictionary")
Set oAcadApp = GetObject(, "AutoCAD.Application")
If Err.Number = 0 Then
Set oAcadDoc = oAcadApp.ActiveDocument
'如果没有错误，表示CAD已经运行
'遍历CAD选择集所有块，采集名字
Set oSset = oAcadDoc.PickfirstSelectionSet
BloCount = oSset.Count
For Each oElem In oSset
If oElem.EntityName = "AcDbBlockReference" Then
Set oBlock = oElem
oBlock.Update
If oBlock.HasAttributes = True Then
oAttrs = oBlock.GetAttributes
For iInt1 = LBound(oAttrs) To UBound(oAttrs)
'oAttrs(0).TextString
d_TagStr(oAttrs(iInt1).TagString) = ""
Next iInt1
End If
End If
Next
'//把块属性字段名，写入窗体
krr = d_TagStr.Keys
For i = 0 To UBound(krr)
Me.ComboBox1.AddItem krr(i)
Next
Me.ComboBox1.ListIndex = 0
'//
ReDim Block_Info(1 To BloCount + 1, 1 To d_TagStr.Count + 2)
'//开始处理块属性信息
For i = 3 To d_TagStr.Count + 2
Block_Info(1, 1) = 99999 'x坐标
Block_Info(1, 2) = 99999 'y坐标
Block_Info(1, i) = krr(i - 3) '把属性写入数组第一行
Next
'开始写块属性
k = 1
For Each oElem In oSset
If oElem.EntityName = "AcDbBlockReference" Then
Set oBlock = oElem
oBlock.Update
If oBlock.HasAttributes = True Then
oAttrs = oBlock.GetAttributes
PtBlock = oBlock.InsertionPoint
k = k + 1
For iInt1 = LBound(oAttrs) To UBound(oAttrs)
txts = oAttrs(iInt1).TextString
tags = oAttrs(iInt1).TagString
col = Getcol(Block_Info, tags)
Block_Info(k, 1) = PtBlock(0) 'x坐标
Block_Info(k, 2) = PtBlock(1) 'y坐标
Block_Info(k, col) = txts '属性值
Next
End If
End If
Next
'//
End If
End Sub
Function Getcol(arr, keystr)
'//返回关键字在数组中的列
For i = 1 To UBound(arr, 2)
If arr(1, i) = keystr Then
Getcol = i
Exit Function
End If
Next
End Function
上述代码中：ArraySortTwo这个对二维数组进行排序的自定义函数过长们需要的单独找我咨询即可。
▎知识点扩展
PickfirstSelectionSet属性
获取命令执行前已经选定了的选择集。通俗的说，就是获取已经选定的所有CAD图元。
Sub Example_PickfirstSelectionSet()
Dim pfSS As AcadSelectionSet
Dim ssobject As AcadEntity
Dim msg As String
msg = vbCrLf
Set pfSS = ThisDrawing.PickfirstSelectionSet
For Each ssobject In pfSS
msg = msg & vbCrLf & ssobject.ObjectName
Next ssobject
MsgBox "选择集包括以下内容： " & msg
End Sub
GetAttributes属性
获取在块参照中的属性。该方法返回一个附着在块参照上可编辑的属性参照数组。
Sub 遍历所有块获取块属性()
For Each oElem In oSset '遍历选择集中所有的块
If oBlock.HasAttributes = True Then '如果该块有块属性，接着就开始读取
oAttrs = oBlock.GetAttributes '获取块属性的属性数组
For iInt1 = LBound(oAttrs) To UBound(oAttrs) '遍历数组
txts = oAttrs(iInt1).TextString '获取块属性的标识文字和值
tags = oAttrs(iInt1).TagString
Next
End If
Next
End Sub