[sae.prc]

Всем добрый день, интересует как с помощью VBA добавлять атрибуты к динамическим и статическим блоками (в случае динамических с параметром видимость - что бы атрибуты были видны во всех состояниях видимости)

[Сергей812]

Сообщение от sae.prc (в случае динамических с параметром видимость - что бы атрибуты были видны во всех состояниях видимости)

просто не включайте атрибуты в операции видимости)

----- добавлено через ~4 мин. -----
А так получаете определение блока, потом к нему через AddAttribute добавляете определение атрибута - примерно так навскидку. Про программное создание/редактирование динблоков забудьте, можно только управлять параметрами готовых уже - если ничего в последних версиях акада не поменялось, конечно

[sae.prc]

Код:

[Выделить все]

Sub AddAttributePritok()
    Dim blk As AcadBlockReference
    Dim att As AcadAttribute
    Dim insertionPoint(0 To 2) As Double
    Dim height As Double
    Dim mode As Long
    Dim prompt As String
    Dim tag As String
    Dim value As String
    
    ' Удалить существующий Selection Set, если он есть
    On Error Resume Next
    ThisDrawing.SelectionSets.Item("SelectionSet").Delete
    On Error GoTo 0
    
    ' Создать новый Selection Set
    Dim selectionSet As AcadSelectionSet
    Set selectionSet = ThisDrawing.SelectionSets.Add("SelectionSet")
    
    ' Проверить, удалось ли создать Selection Set
    If Not selectionSet Is Nothing Then
        ' Предоставить пользователю возможность выбрать объекты
        selectionSet.SelectOnScreen
        ' Перебрать все выбранные объекты
        For Each obj In selectionSet
            ' Проверить, является ли объект блоком
            If TypeOf obj Is AcadBlockReference Then
                Set blk = obj
                ' Задать параметры атрибута
                height = 1#
                mode = acAttributeModeInvisible
                prompt = "тест"
                insertionPoint(0) = 5#: insertionPoint(1) = 5#: insertionPoint(2) = 0
                tag = "тест"
                value = "привет"
                ' Создать новый атрибут
                Set att = blk.AddAttribute(height, mode, prompt, insertionPoint, tag, value)
                ' Обработать ситуацию, если добавление атрибута не удалось
                If Not att Is Nothing Then
                    MsgBox "Атрибут успешно добавлен к блоку."
                Else
                    MsgBox "Ошибка при добавлении атрибута к блоку.", vbExclamation
                End If
            End If
        Next obj
        ' Удалить Selection Set после использования
        selectionSet.Delete
    End If
End Sub

набросал код для добавления одного атрибута - ошибка в строке set att = blk.addattribute

[Сергей812]

Сообщение от sae.prc set att = blk.addattribute

потому что blk -> AcadBlockReference, а не AcadBlock

----- добавлено через ~43 мин. -----
атрибуты создаются для хранения информации?

[sae.prc]

Сообщение от Сергей812 атрибуты создаются для хранения информации?

Да

[Сергей812]

в общем, надо править не вставки блоков AcadBlockReference, а их определения AcadBlock. Т.е. по вставкам блоков определить имя блоков с учетом их динамичности (можно использовать ту же Collection для сбора неповторяющихся имен блоков - имя блок и как ключ, и как значение). И потом уже пройтись по этой коллекции имен блоков и из ThisDrawing.Blocks получить определения блоков, а к ним (определениям атрибутов) уже добавить желаемый атрибут.

[sae.prc]

Благодарю за идею! Буду пробовать!

[sae.prc]

Код:

[Выделить все]

Sub AddAttributePritok()
    Dim blk As AcadBlock
    Dim blkrf As AcadBlockReference
    Dim att As AcadAttribute
    Dim insertionPoint(0 To 2) As Double
    Dim height As Double
    Dim mode As Long
    Dim value As String
    Dim blkname As String
    Dim attributeValues As New Collection

    ' Добавление значений в коллекцию attributeValues
    attributeValues.Add "ОБОЗНАЧЕНИЕ_СИСТЕМЫ"
    attributeValues.Add "НАИМЕНОВАНИЕ_ОБСЛУЖИВАЕМОГО_ПОМЕЩЕНИЯ"
    attributeValues.Add "ТИП_НАИМЕНОВАНИЕ"
    attributeValues.Add "ВЕНТИЛЯТОР_РАСХОД"
    attributeValues.Add "ВЕНТИЛЯТОР_НАПОР"
    attributeValues.Add "ВЕНТИЛЯТОР_ЧАСТОТА_ВРАЩЕНИЯ_ВЕНТИЛЯТОРА"
    attributeValues.Add "ЭЛЕКТРОДВИГАТЕЛЬ_ТИП"
    attributeValues.Add "ЭЛЕКТРОДВИГАТЕЛЬ_МОЩНОСТЬ_КВТ"
    attributeValues.Add "ЭЛЕКТРОДВИГАТЕЛЬ_НАПРЯЖЕНИЕ"
    attributeValues.Add "ЭЛЕКТРОДВИГАТЕЛЬ_ЧАСТОТА_ВРАЩЕНИЯ"
    attributeValues.Add "ВОЗДУХОНАГРЕВАТЕЛЬ_ТИП"
    attributeValues.Add "ВОЗДУХОНАГРЕВАТЕЛЬ_КОЛИЧЕСТВО"
    attributeValues.Add "ВОЗДУХОНАГРЕВАТЕЛЬ_ТЕМПЕРАТУРА_НАРУЖНОГО_ВОЗДУХА"
    attributeValues.Add "ВОЗДУХОНАГРЕВАТЕЛЬ_ТЕМПЕРАТУРА_ВНУТРЕННЕГО_ВОЗДУХА"
    attributeValues.Add "ВОЗДУХОНАГРЕВАТЕЛЬ_РАСХОД_ТЕПЛОТЫ_ВТ"
    attributeValues.Add "ВОЗДУХОНАГРЕВАТЕЛЬ_ПОТЕРИ_ПО_ВОЗДУХУ_ПА"
    attributeValues.Add "ВОЗДУХОНАГРЕВАТЕЛЬ_ПОТЕРИ_ПО_ВОДЕ_ПА"
    attributeValues.Add "ВОЗДУХООХЛАДИТЕЛЬ_ТИП"
    attributeValues.Add "ВОЗДУХООХЛАДИТЕЛЬ_КОЛИЧЕСТВО"
    attributeValues.Add "ВОЗДУХООХЛАДИТЕЛЬ_ТЕМПЕРАТУРА_ОХЛАЖДЕНИЯ_ОТ"
    attributeValues.Add "ВОЗДУХООХЛАДИТЕЛЬ_ТЕМПЕРАТУРА_ОХЛАЖДЕНИЯ_ДО"
    attributeValues.Add "ВОЗДУХООХЛАДИТЕЛЬ_РАСХОД_ХОЛОДА_ВТ"
    attributeValues.Add "ВОЗДУХООХЛАДИТЕЛЬ_ПОТЕРИ_ПА"
    attributeValues.Add "НАСОС_ТИП"
    attributeValues.Add "НАСОС_ПОДАЧА_М3/Ч"
    attributeValues.Add "НАСОС_НАПОР_МПА"
    attributeValues.Add "НАСОС_ЭЛЕКТРОДВИГАТЕЛЬ_ТИП"
    attributeValues.Add "НАСОС_ЭЛЕКТРОДВИГАТЕЛЬ_МОЩНОСТЬ_КВТ"
    attributeValues.Add "НАСОС_ЭЛЕКТРОДВИГАТЕЛЬ_ЧАСТОТА_ОБОРОТОВ"
    attributeValues.Add "ФИЛЬТР_ТИП"
    attributeValues.Add "ФИЛЬТР_КОЛИЧЕСТВО"
    attributeValues.Add "ФИЛЬТР_ПОТЕРИ_ЧИСТЫЕ_ФИЛЬТРЫ_ПА"
    attributeValues.Add "ПРИМЕЧАНИЕ"
    ' Добавьте остальные значения атрибутов сюда

    ' Удаление существующего Selection Set, если он есть
    On Error Resume Next
    ThisDrawing.SelectionSets.Item("SelectionSet").Delete
    On Error GoTo 0
    
    ' Создание нового Selection Set
    Dim selectionSet As AcadSelectionSet
    Set selectionSet = ThisDrawing.SelectionSets.Add("SelectionSet")
    
    ' Проверка, удалось ли создать Selection Set
    If Not selectionSet Is Nothing Then
        ' Предоставление пользователю возможности выбрать объекты
        selectionSet.SelectOnScreen
        
        ' Перебор всех выбранных объектов
        For Each obj In selectionSet
            ' Проверка, является ли объект блоком
            If TypeOf obj Is AcadBlockReference Then
                blkname = obj.EffectiveName
                Set blk = ThisDrawing.Blocks.Item(blkname)
                
                ' Сохранение координат вставки блока
                Dim pp As Variant
                pp = obj.insertionPoint
                
                ' Задание параметров атрибута
                height = 250#
                mode = acAttributeModeInvisible
                
                ' Добавление атрибутов на основе значений из коллекции
                Dim yOffset As Double
                yOffset = 0
                For i = 1 To attributeValues.Count
                    value = attributeValues(i)
                    insertionPoint(0) = pp(0)
                    insertionPoint(1) = pp(1) - yOffset
                    insertionPoint(2) = pp(2)
                    
                    ' Создание нового атрибута
                    Set att = blk.AddAttribute(height, mode, "", insertionPoint, value, "")
                    
                    ' Увеличение смещения по Y для следующего атрибута
                    yOffset = yOffset + 300
                Next i
                
                ' Удаление блока после добавления атрибутов
                obj.Delete
                
                ' Вставка блока снова в исходные координаты
                Set blkrf = ThisDrawing.ModelSpace.InsertBlock(pp, blkname, 1#, 1#, 1#, 0)
            End If
        Next obj
        
        ' Вывод сообщения об успешном добавлении атрибутов
        MsgBox "Атрибуты успешно добавлены.", vbInformation
        
        ' Удаление Selection Set после использования
        selectionSet.Delete
    End If
End Sub

Спасибо, Сергей еще раз, что то более менее рабочее получилось - буду конечно еще допиливать, но уже хоть что то

[Сергей812]

Код:

[Выделить все]

' Проверка, является ли объект блоком
            If TypeOf obj Is AcadBlockReference Then
                blkname = obj.EffectiveName
                Set blk = ThisDrawing.Blocks.Item(blkname)

а если две и более вставки одного и того же блока будут выделены? Писал же выше

Сообщение от Сергей812 Т.е. по вставкам блоков определить имя блоков с учетом их динамичности (можно использовать ту же Collection для сбора неповторяющихся имен блоков - имя блок и как ключ, и как значение).

т.е. заключить цикл прохода по выделенным объектам в On Error Resume Next, пытаемся добавить в коллекцию Col.Add Key=%Имя блока% Value = %Имя блока% и если словили ошибку 457 (вроде так, по памяти пишу), то сбрасываем обработчик ошибок Err.Clear и дальше пошли на следующую иттерацию цикла.

Ну и не будет лишним проверять самое определение блока - не является ли оно внешней ссылкой (свойство IsXRef), прежде чем туда добавлять атрибуты. А также пройтись в цикле по элементам определения блока For Each lItem In blk и найти объект AcadAttribute с именем с из attributeValues(1) - защита от повторного добавления атрибутов.

И, кстати, логически не верно название коллекции - attributeValues, так как это теги (Tag).

[sae.prc]

Спасибо, Сергей, за конструктивную информацию, уточню что я не программист, а проектировщик, который пытается немного упростить жизнь (chatGPT иногда в помощь), буду доводить код до ума! Еще раз спасибо!

----- добавлено через ~2 мин. -----
Так же может подскажите, как вытащить текущее состояние видимости и присвоить его при вставке блока заново?

[name02]

Сообщение от sae.prc Так же может подскажите, как вытащить текущее состояние видимости и присвоить его при вставке блока заново?

К сожалению, получить из блока именно параметр видимости не получится - все параметры динамического блока хранятся в GetDynamicBlockProperties, но без указания, что это за параметр - я уже пробовал такое сделать (см. пост тут)
Получить же список параметров несложно:

Код:

[Выделить все]

 If newBlock.IsDynamicBlock = True Then

            objPropSet = newBlock.GetDynamicBlockProperties
            i = 0

            'Заполняем массив с параметрами и их значениями
            For i = 0 To UBound(objPropSet)

                Set objProp = objPropSet(i)

                'имя параметра из блока - в верхнем регистре
                prop_name = StrConv(objProp.PropertyName, 1)

                'У блока есть служебный параметр ORIGIN - его не рассматриваем
                If prop_name <> "ORIGIN" Then
                
                    'Я сделал свой класс для данных получаемых из блока, но принцип понятен
                    Dim prop As clsBlockData
                    Set prop = New clsBlockData

                    Set prop.Entity = objProp
                    prop.Value = objProp.Value 'значение параметра
                    prop.Units = cmCustom 'тип данных
                    prop.Name = prop_name
                    prop.AllowedValues = objProp.AllowedValues 'допустимые значения (например названия состояния видимости)

                    prop.ReadOnly = objProp.ReadOnly 'параметр может быть доступен только для чтения

                End If
                
            Next
End If

Если у тебя заранее определено название видимости, то ты сможешь его таким образом получить.
Справка по GetDynamicBlockProperties здесь

Для записи в блок нужно сделать обратный алгоритм:

Код:

[Выделить все]

 For Each objProp In newBlock.GetDynamicBlockProperties

                If objProp = "НУЖНОЕ_ИМЯ_ВИДИМОСТИ" Then
                    'Значение должно иметь соответствующий тип данных
                    'а сам параметр доступен для записи (objProp.ReadOnly=False)
                    objProp .Value = НУЖНОЕ_ЗНАЧЕНИЕ

                End If
                
            Next
End If

[sae.prc]

Дак вот, получается что по имени параметра (допустим "Видимость1") можно получить значение, но если имя видимости в каком то блоке будет отлично то уже никак не сохранить состояние видимости?

[name02]

У произвольного блока, в котором ты не знаешь названия параметров ты не сможешь определить тип параметра - видимость или линейный, а может и параметр выбора

[sae.prc]

Спасибо за информацию!

----- добавлено через ~19 мин. -----
Может можно тогда как то обновить вхождение блока, что бы атрибуты появились без новой вставки блока?

[name02]

Сообщение от sae.prc Может можно тогда как то обновить вхождение блока, что бы атрибуты появились без новой вставки блока?

https://help.autodesk.com/view/OARX/...B-CB4CC93D533F

[sae.prc]

c Update пробовал - не получилось. Но попробую еще раз, раз говорите может помочь

[Сергей812]

Выбор VBA для подобной задачи - заведомо путь страданий, имхо. Чтобы иметь возможность править значения параметров в удобном виде в палитре, приходится добавлять атрибуты - так как VBA (как и лисп) просто не умеют работать с палитрами напрямую. А так можно было бы и в те же XData добавлять данные, причем к любому из примитивов - 16кб данных не так уж и мало при грамотном пользовании.

Offtop:

Сообщение от sae.prc уточню что я не программист, а проектировщик,

да тут почти все не программисты, а просто инженеры-самоучки. Буквально по пальцам можно посчитать профессиональных (по роду основной деятельности) программистов)

[sae.prc]

Пока лишь предметно стоит задача - добавить свои атрибуты к блокам, можно конечно и копированием в лоб решать данную задачу, вариант вполне рабочий, но так как задача рутинная, решил попробовать автоматизировать. По поводу VBA могу сказать лишь только то что просто раньше когда то давным давно был с ним знаком поверхностно, и так как с помощью vba какие то базовые задачи можно автоматизировать для выполнения текущих задач - вполне устроило

[Сергей812]

да нормально, сам в свое время начинал программирование в акаде с VBA) Просто язык программирования уже десятки лет стоит на месте со всеми вытекающими, при этом он (VBA) изначально был уже урезанной версией VisualBasic.

[sae.prc]

Тогда как и в чем предметно посоветовали бы решить данную задачу Вы (если можно с описанием)?