Икс Дата

Sub AttachXDataToSelectionSetObjects()
    ' Создаем набор
    Dim sset As Object
    Set sset = ThisDrawing.SelectionSets.Add("SS1")
    ' Предложим пользователю выбрать объекты
    sset.SelectOnScreen
    ' Определим расширенные данные
    Dim appName As String, xdataStr As String
    appName = "MY_APP"
    xdataStr = "Пример xdata (дополнительных данных)"
    Dim xdataType(0 To 1) As Integer
    Dim xdata(0 To 1) As Variant
    ' Зададим значения для каждого массива
    ' 1001 = appName
    xdataType(0) = 1001
    xdata(0) = appName
    ' 1000 отображает строковое значение
    xdataType(1) = 1000
    xdata(1) = xdataStr
    ' Проходим по элементам набора и устанавливаем
    ' каждому расширенные данные
    Dim ent As Object
    For Each ent In sset
        ent.SetXData xdataType, xdata
    Next ent
End Sub
Sub ViewXData()
    ' Ищем набор, созданный в предыдущем примере
    Dim sset As Object
    Set sset = ThisDrawing.SelectionSets.Item("SS1")
    ' Создаем переменные для хранения расширенных данных
    Dim xdataType As Variant
    Dim xdata As Variant
    Dim xd As Variant
    Dim xdi As Integer
    xdi = 0
    ' Проходим по всем объектам набора, читая расширенные данные
    Dim msgstr As String
    Dim appName As String
    Dim ent As AcadEntity
    appName = "MY_APP"
    For Each ent In sset
        msgstr = ""
        xdi = 0
        ' Имя приложения (appName) xdata Тип и Значение
        ent.GetXData appName, xdataType, xdata
        ' Если переменная xdataType не инициализирована, не
        ' будет appName xdata
        If VarType(xdataType) <> vbEmpty Then
            For Each xd In xdata
                msgstr = msgstr & vbCrLf & xdataType(xdi) & ": " & xd
                xdi = xdi + 1
            Next xd
        End If
        ' Если полученная строка пуста (NULL), нет расширенных данных
        If msgstr = "" Then msgstr = vbCrLf & "NONE"
        MsgBox appName & " xdata " & ent.ObjectName & ":" & vbCrLf & msgstr
    Next ent
End Sub