▎具体需求 使用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这个对二维数组进行排序的自定义函数过长们需要的单独找我咨询即可。 ▎知识点扩展 获取命令执行前已经选定了的选择集。通俗的说,就是获取已经选定的所有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
获取在块参照中的属性。该方法返回一个附着在块参照上可编辑的属性参照数组。
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
|