Sub Example_AddXRecord()
    ' Этот пример создает новый XRecord, добавляете в конец данные XRecord
    ' и затем читаете их обратно. Чтобы видеть, что данные добавленны,
    ' выполните пример несколько раз.
    
    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
    
    ' Уникальные идентификаторы, чтобы отличить этот XRecordData от другого XRecordData
    Const TYPE_STRING = 1
    Const TAG_DICTIONARY_NAME = "ObjectTrackerDictionary"
    Const TAG_XRECORD_NAME = "ObjectTrackerXRecord"

    ' Соединитесь со словарем, чтобы сохранить XRecord
    On Error GoTo CREATE
    Set TrackingDictionary = ThisDrawing.Dictionaries(TAG_DICTIONARY_NAME)
    Set TrackingXRecord = TrackingDictionary.GetObject(TAG_XRECORD_NAME)
    On Error GoTo 0
    
    ' Получите текущий XRecordData
    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
    
    ' Добавьте в конец новые XRecord Данные
    '
    ' Для этой выборки мы только добавляем в конец XRecord текущее время
    XRecordDataType(ArraySize) = TYPE_STRING: XRecordData(ArraySize) = CStr(Now)
    TrackingXRecord.SetXRecordData XRecordDataType, XRecordData
    
    ' Считайте назад все XRecordData
    TrackingXRecord.GetXRecordData XRecordDataType, XRecordData
    ArraySize = UBound(XRecordDataType)
    
    ' Восстановите и покажите сохраненный XRecordData
    For iCount = 0 To ArraySize
        ' Получите информацию для этого элемента
        DataType = XRecordDataType(iCount)
        Data = XRecordData(iCount)
        
        If DataType = TYPE_STRING Then
            msg = msg & Data & vbCrLf
        End If
    Next
    
    MsgBox "Данные в XRecord: " & vbCrLf & vbCrLf & msg, vbInformation
    
    Exit Sub

CREATE:
    ' Создайте объекты, которые содержат этот XRecordData
    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

Сайт управляется системой uCoz