IT Knowledge Base

~ Without sacrifice, there can be no victory ~

發佈日期:

分類:

, ,

如何在AutoCAD中‧使用VBA找出圖檔中Attribute Block中的內容

幾萬張圖檔(Drawing)中,款式真的是應有盡有,所指的款式,不是指內容的款式,而是各有各的畫法,各有各的表達方式,要把它們的基本資料找出來,就像要使出百多種的方法,怪不知要請我來做啦!

Public Sub getAttributeReference()
Dim objReturn As AcadObject
Dim revObj As AcadObject
Dim varBasePoint, revBasePoint As Variant
Dim strBlockName As String
Dim revString As String
Dim avarAttributes As Variant
Dim intIndex As Integer
Dim objBlockReference As AcadBlockReference
Dim revObjReference As AcadText
Dim objAcadAttributeReference  As AcadAttributeReference
Dim strShowMessage As String
Call ThisDrawing.Utility.GetEntity(objReturn, varBasePoint, "Select attribute block: ")
If objReturn.ObjectName = "AcDbBlockReference" Then
Set objBlockReference = objReturn
strBlockName = objBlockReference.Name
strShowMessage = "Attribute block name: " + strBlockName + vbCr
If objBlockReference.HasAttributes Then
avarAttributes = objBlockReference.GetAttributes
For intIndex = LBound(avarAttributes) To UBound(avarAttributes)
Set objAcadAttributeReference = avarAttributes(intIndex)
If objAcadAttributeReference.ObjectName = "AcDbAttribute" Then
Select Case objAcadAttributeReference.TagString
''Modify the selection case for your drawing.
Case "REV"
rev = objAcadAttributeReference.TextString
Case "TITLE1"
t1 = objAcadAttributeReference.TextString
Case "TITLE2"
t2 = objAcadAttributeReference.TextString
Case "TITLE3"
t3 = objAcadAttributeReference.TextString
Case "TITLE4"
t4 = objAcadAttributeReference.TextString
Case "TITLE5"
t5 = objAcadAttributeReference.TextString
Case "DRAWN"
drawnBy = objAcadAttributeReference.TextString
Case "CHECK"
checkedBy = objAcadAttributeReference.TextString
Case "APPROVE"
approvedBy = objAcadAttributeReference.TextString
Case "DWGNO"
dwgNo = objAcadAttributeReference.TextString
Case "PROJ1"
p1 = objAcadAttributeReference.TextString
Case "PROJ2"
p2 = objAcadAttributeReference.TextString
Case "PROJ3"
p3 = objAcadAttributeReference.TextString
Case "PROJ4"
p4 = objAcadAttributeReference.TextString
End Select
End If
Next intIndex
End If
titleName = t1 + " " + t2 + " " + t3 + " " + t4
projectName = p1 + " " + p2 + " " + p3 + " " + p4
End If
''Compose all information of drawing into sentense.
txtTotal = DwgNo + ";" + rev + ";" + titleName + ";;;" + drawnBy + ";;" + checkedBy + ";;" + approvedBy + ";;;" + projectName
dwgPre = ThisDrawing.GetVariable("dwgprefix")
dwgNam = ThisDrawing.GetVariable("dwgname")
dwgInfo = dwgPre + dwgNam
dwgAll = dwgInfo + ";" + txtTotal
''Add all drawing information into a file.
Open "writeToFile.txt" For Append As #1
Write #1, dwgAll
Close #1
End Sub

發佈留言

發佈留言必須填寫的電子郵件地址不會公開。 必填欄位標示為 *