[VBA程序]：用VBA如何存取cad图的图形属性？

pbh001

请问那位高手知道如何用vba存取cad图的自定义图形属性，这里指的是文件菜单下的图形属性，而不是块属性，这个问题已困扰我好久了。

gdzhou

整个图片，看不懂啊

yefeng1860

期待

tsuihan

用XRecord来访问。

VBA 类名:         AcadXRecord
建立方法:         Dictionary.AddXRecord
访问途径:         Dictionary.Item

如下例里的这句是关键：
Set TrackingDictionary = ThisDrawing.Dictionaries(TAG_DICTIONARY_NAME)
Set TrackingXRecord = TrackingDictionary.GetObject(TAG_XRECORD_NAME)
TrackingXRecord.GetXRecordData XRecordDataType, XRecordData


对于AutoCAD"文件"菜单下的‘工具’里的“图形属性”，里面所保存的“扩展记录”，
目前我还没找到它所对应的XRecord的字典名和标签名。有空我再找找，给个例子你参考先；你也可以分析DXF来找找看。

提示 ：
此对象和XData比较类似，但它没有大小和次序限制；
与XData不同，XRecords是标准的AutoCAD组码。
DXF查看源码，发现那些自定义属性放在组码1-369 (除了5和105) 里。

''我找到了一个AutoCAD自带的例子，你先看看；


''====================================================================

Sub Example_AddXRecord()
    ' This example creates a new XRecord if one doesn't exist,
    ' appends data to the XRecord and reads it back.  To see data being added
    ' run the example more than once.
   
    Dim TrackingDictionary As AcadDictionary, TrackingXRecord As AcadXRecord
    Dim XRecordDataType As Variant, XRecordData As Variant
    Dim ArraySize As Long, iCount As Long
    Dim DataType As Integer, Data As String, msg As String
   
    ' Unique identifiers to distinguish our XRecordData from other XRecordData
    Const TYPE_STRING = 1
    Const TAG_DICTIONARY_NAME = "ObjectTrackerDictionary"
    Const TAG_XRECORD_NAME = "ObjectTrackerXRecord"

    ' Connect to the dictionary we store the XRecord in
    On Error GoTo CREATE
    Set TrackingDictionary = ThisDrawing.Dictionaries(TAG_DICTIONARY_NAME)
    Set TrackingXRecord = TrackingDictionary.GetObject(TAG_XRECORD_NAME)
    On Error GoTo 0
   
    ' Get current XRecordData
    TrackingXRecord.GetXRecordData XRecordDataType, XRecordData
   
    ' If we don't have an array already then create one
    If VarType(XRecordDataType) And vbArray = vbArray Then
        ArraySize = UBound(XRecordDataType) + 1       ' Get the size of the data elements returned
        ArraySize = ArraySize + 1                        ' Increase to hold new data
   
        ReDim Preserve XRecordDataType(0 To ArraySize)
        ReDim Preserve XRecordData(0 To ArraySize)
    Else
        ArraySize = 0
        ReDim XRecordDataType(0 To ArraySize) As Integer
        ReDim XRecordData(0 To ArraySize) As Variant
    End If
   
    ' Append new XRecord Data
    '
    ' For this sample we only append the current time to the XRecord
    XRecordDataType(ArraySize) = TYPE_STRING: XRecordData(ArraySize) = CStr(Now)
    TrackingXRecord.SetXRecordData XRecordDataType, XRecordData
   
    ' Read back all XRecordData entries
    TrackingXRecord.GetXRecordData XRecordDataType, XRecordData
    ArraySize = UBound(XRecordDataType)
   
    ' Retrieve and display stored XRecordData
    For iCount = 0 To ArraySize
        ' Get information for this element
        DataType = XRecordDataType(iCount)
        Data = XRecordData(iCount)
        
        If DataType = TYPE_STRING Then
            msg = msg & Data & vbCrLf
        End If
    Next
   
    MsgBox "The data in the XRecord is: " & vbCrLf & vbCrLf & msg, vbInformation
   
    Exit Sub

CREATE:
    ' Create the entities that hold our XRecordData
    If TrackingDictionary Is Nothing Then  ' Make sure we have our tracking object
        Set TrackingDictionary = ThisDrawing.Dictionaries.Add(TAG_DICTIONARY_NAME)
        Set TrackingXRecord = TrackingDictionary.AddXRecord(TAG_XRECORD_NAME)
    End If
   
    Resume
End Sub

npzh585

4楼的我怎么看不明白呀？

geron

我怎么看不明白呀？

yoursmile

我需要怎么处理块属性的！