[求助]能否用EXCEL VBA向XRecord中写数据？
能否用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
页:
[1]