[求助]能否用EXCEL VBA向XRecord中写数据？

kate125

能否用EXCEL 中的VBA向Auto CAD中XRecord中写数据？

    在Auto CAD内部可以用VBA操作XRecord，不知道能否用EXCEL 中的VBA向Auto CAD中XRecord中写数据？

    还请高手赐教！

VBA操作XRECORD的示例代码:

Sub Example_AddXRecord()
    ' 该示例在扩展记录不存在时创建一个新的扩展记录，
    ' 并添加数据到该扩展记录中，然后将其读出。
    ' 要查看已经添加的数据，可再运行一次该示例。
   
    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
   
    ' 识别该扩展记录数据的唯一标识符
    Const TYPE_STRING = 1
    Const TAG_DICTIONARY_NAME = "ObjectTrackerDictionary"
    Const TAG_XRECORD_NAME = "ObjectTrackerXRecord"

    ' 连接保存扩展记录的词典
    On Error GoTo CREATE
    Set TrackingDictionary = ThisDrawing.Dictionaries(TAG_DICTIONARY_NAME)
    Set TrackingXRecord = TrackingDictionary.GetObject(TAG_XRECORD_NAME)
    On Error GoTo 0
   
    ' 获取当前的扩展记录
    TrackingXRecord.GetXRecordData XRecordDataType, XRecordData
   
    ' 如果数组不存在则创建一个
    If VarType(XRecordDataType) And vbArray = vbArray Then
        ArraySize = UBound(XRecordDataType) + 1       ' 获取数据元素返回的大小
        ArraySize = ArraySize + 1                        ' 增量保持新的数据
   
        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
   
    ' 添加新的扩展记录数据
    '
    ' 在本例中只添加当前时间到扩展记录中
    XRecordDataType(ArraySize) = TYPE_STRING: XRecordData(ArraySize) = CStr(Now)
    TrackingXRecord.SetXRecordData XRecordDataType, XRecordData
   
    ' 读出所有的扩展记录数据条目
    TrackingXRecord.GetXRecordData XRecordDataType, XRecordData
    ArraySize = UBound(XRecordDataType)
   
    ' 找到并显示保存的扩展记录数据
    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 "在该扩展记录中的数据为: " & vbCrLf & vbCrLf & msg, vbInformation
   
    Exit Sub

CREATE:
    ' 创建用于保持这些扩展记录数据的对象
    If TrackingDictionary Is Nothing Then  ' 确认已经有跟踪对象
        Set TrackingDictionary = ThisDrawing.Dictionaries.Add(TAG_DICTIONARY_NAME)
        Set TrackingXRecord = TrackingDictionary.AddXRecord(TAG_XRECORD_NAME)
    End If
   
    Resume
End Sub