▎具體需求
使用CAD的人都知道圖塊，因?yàn)閳D塊可以重復(fù)插入、做成圖庫(kù)，減少重復(fù)操作，被廣泛使用。
當(dāng)圖塊中有一些文字屬性需要經(jīng)常修改的時(shí)候，我們就可以在圖塊中添加屬性文字，并定義成屬性塊。比如一些圖框塊，將零散的圖元做成塊，可以實(shí)現(xiàn)批量插入并修改的效果。
有插入就有導(dǎo)出，當(dāng)我們需要獲取屬性塊中的各個(gè)屬性內(nèi)容的時(shí)候，挨個(gè)獲取屬性塊的信息特別的繁瑣，需要打開(kāi)塊屬性，手動(dòng)復(fù)制粘貼。
這個(gè)時(shí)候我們就想到利用程序?qū)崿F(xiàn)批量讀取屬性塊的內(nèi)容。
▎思路分析
大概流程：
用戶選擇一批圖元→點(diǎn)擊程序按鈕，后臺(tái)循環(huán)獲取圖元的屬性?！敵鏊袑傩缘絜xcel中。
有幾個(gè)小細(xì)節(jié)需要考慮周全。
①獲取的塊屬性個(gè)數(shù)不一定相同，需要獲取所有塊屬性標(biāo)題。
②因?yàn)閴K的位置不同，需要根據(jù)塊的坐標(biāo)進(jìn)行排列最終的屬性。
程序界面
▎效果及源代碼
效果：
代碼是在Excel中的，通過(guò)excel鏈接CAD，并且讀取屬性。
Public Block_Info '存儲(chǔ)塊屬性的坐標(biāo)及具體數(shù)據(jù)
Private Sub CommandButton1_Click()
'//導(dǎo)出單個(gè)屬性
'//開(kāi)始對(duì)屬性按坐標(biāo)排序
Dim Result()
bol = IIf(Me.OptionButton1.Value = True, 2, 1)
Block_Info = ArraySortTwo(Block_Info, bol, SortDESC) '按坐標(biāo)降序排列的屬性數(shù)組
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 "導(dǎo)出完成！"
Unload Me
End Sub
Private Sub CommandButton2_Click()
'//導(dǎo)出所有塊屬性
'//開(kāi)始對(duì)屬性按坐標(biāo)排序
Dim Result()
bol = IIf(Me.OptionButton1.Value = True, 2, 1)
Block_Info = ArraySortTwo(Block_Info, bol, SortDESC) '按坐標(biāo)降序排列的屬性數(shù)組
'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 "導(dǎo)出完成！"
Unload Me
End Sub
Private Sub UserForm_Initialize()
'//窗體加載初始化事件，有一些必要的錯(cuò)誤判斷，以及讀取塊屬性到數(shù)組中。
Me.OptionButton1.Value = True
Set d_TagStr = CreateObject("scripting.dictionary")
Set oAcadApp = GetObject(, "AutoCAD.Application")
If Err.Number = 0 Then
Set oAcadDoc = oAcadApp.ActiveDocument
'如果沒(méi)有錯(cuò)誤，表示CAD已經(jīng)運(yùn)行
'遍歷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
'//把塊屬性字段名，寫(xiě)入窗體
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)
'//開(kāi)始處理塊屬性信息
For i = 3 To d_TagStr.Count + 2
Block_Info(1, 1) = 99999 'x坐標(biāo)
Block_Info(1, 2) = 99999 'y坐標(biāo)
Block_Info(1, i) = krr(i - 3) '把屬性寫(xiě)入數(shù)組第一行
Next
'開(kāi)始寫(xiě)塊屬性
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坐標(biāo)
Block_Info(k, 2) = PtBlock(1) 'y坐標(biāo)
Block_Info(k, col) = txts '屬性值
Next
End If
End If
Next
'//
End If
End Sub
Function Getcol(arr, keystr)
'//返回關(guān)鍵字在數(shù)組中的列
For i = 1 To UBound(arr, 2)
If arr(1, i) = keystr Then
Getcol = i
Exit Function
End If
Next
End Function
上述代碼中：ArraySortTwo這個(gè)對(duì)二維數(shù)組進(jìn)行排序的自定義函數(shù)過(guò)長(zhǎng)們需要的單獨(dú)找我咨詢即可。
▎知識(shí)點(diǎn)擴(kuò)展
PickfirstSelectionSet屬性
獲取命令執(zhí)行前已經(jīng)選定了的選擇集。通俗的說(shuō)，就是獲取已經(jīng)選定的所有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 "選擇集包括以下內(nèi)容： " & msg
End Sub
GetAttributes屬性
獲取在塊參照中的屬性。該方法返回一個(gè)附著在塊參照上可編輯的屬性參照數(shù)組。
Sub 遍歷所有塊獲取塊屬性()
For Each oElem In oSset '遍歷選擇集中所有的塊
If oBlock.HasAttributes = True Then '如果該塊有塊屬性，接著就開(kāi)始讀取
oAttrs = oBlock.GetAttributes '獲取塊屬性的屬性數(shù)組
For iInt1 = LBound(oAttrs) To UBound(oAttrs) '遍歷數(shù)組
txts = oAttrs(iInt1).TextString '獲取塊屬性的標(biāo)識(shí)文字和值
tags = oAttrs(iInt1).TagString
Next
End If
Next
End Sub
聯(lián)系客服
