ADN Club > VBA
Присвоение объекту символьного идентификатора заданного пользователем.
Vladimir:
Добрый день!
Появилась необходимость обраться к объекту по его идентификатору заданному мной.
--- Код - Visual Basic [Выбрать] ---Set Obj = ThisDrawing.ModelSpace.Item(mark)Возможно ли присвоить объекту свой идентификатор?
Пример, ссылки, совет преветствуется.
Александр Ривилис:
Тут есть два варианта:
1. Воспользоваться XDATA (расширенные данные). Создаёшь RegisteredApplication с нужным тебе именем и добавляешь к своему объекту XDATA с указанным именем. И тогда нужно будет фильтровать по имени расширенного данного.
2. Воспользоваться NOD (Named Object Dictionary - словарь именованных объектов). Тут нужно будет создавать XRecord, в которой присутствует ObjectId нужного тебе примитива.
Первый способ проще для реализации, но если количество объектов, которым "нужно присвоить имя" велико, то чертеж будет замусорен объектами RegisteredApplication. Ну и быстродействие будет не слишком велико, так как при поиске по имени будет просматриваться вся база чертежа.
Александр Ривилис:
В таком виде это сделать нельзя:
--- Цитата: Vladimir от 14-06-2015, 09:13:54 ---Set Obj = ThisDrawing.ModelSpace.Item(mark)
--- Конец цитаты ---
Александр Ривилис:
Вот так (без проверок на ошибки) и с учетом того, что на VBA я совсем не пишу:
--- Код - Visual Basic [Выбрать] ---Sub AddKeyMark() Dim obj As AcadObject Dim pt As Variant On Error Resume Next ThisDrawing.Utility.GetEntity obj, pt, "Выберите примитив: " If ERR <> 0 Then ERR.Clear: Exit Sub End If Dim key As String ThisDrawing.Utility.InitializeUserInput 1 key = ThisDrawing.Utility.GetString(False, "Укажите ключ: ") If ERR <> 0 Then ERR.Clear: Exit Sub End If Dim dict As AcadDictionary Set dict = ThisDrawing.Dictionaries.Add("NAMED_ENTITIES") Dim xrec As AcadXRecord Set xrec = dict.AddXRecord(key) Dim XRecordDataType As Variant, XRecordData As Variant Dim ArraySize As Long, iCount As Long xrec.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) = 105: XRecordData(ArraySize) = obj.Handle xrec.SetXRecordData XRecordDataType, XRecordDataEnd Sub Sub CheckKeyMark() Dim obj As AcadObject Dim pt As Variant On Error Resume Next Dim key As String ThisDrawing.Utility.InitializeUserInput 1 key = ThisDrawing.Utility.GetString(False, "Укажите ключ: ") If ERR <> 0 Then ERR.Clear: Exit Sub End If Dim dict As AcadDictionary Set dict = ThisDrawing.Dictionaries.Add("NAMED_ENTITIES") Dim xrec As AcadXRecord Set xrec = dict(key) If ERR <> 0 Then ERR.Clear: Exit Sub End If Dim XRecordDataType As Variant, XRecordData As Variant Dim ArraySize As Long, iCount As Long xrec.GetXRecordData XRecordDataType, XRecordData If ERR <> 0 Then ERR.Clear: Exit Sub End If If VarType(XRecordDataType) And vbArray = vbArray Then ArraySize = UBound(XRecordDataType) + 1 For iCount = 0 To ArraySize If XRecordDataType(iCount) = 105 Then Dim h As String h = XRecordData(iCount) Set obj = ThisDrawing.HandleToObject(h) Dim ent As AcadEntity Set ent = obj ent.Highlight True key = ThisDrawing.Utility.GetString(False, _ "Подсвечен выбранный примитив. Для продолжения - ENTER") ent.Highlight False Exit For End If Next End IfEnd Sub
Первая функция добавляем примитиву "имя" (ключ). Вторая по "имени" находит примитив и подсвечивает его.
Vladimir:
Ок, спасибо.
Завтра попробую и отпишусь....
Навигация
Перейти к полной версии