ADN Club > VBA
Макрос вставки блока в точки вставки имеющихся в чертеже блоков
sae.prc:
Добрый день, имеется макрос суть которого в том, что бы в места вставки одних блоков вставить другой блок.
Алгоритм изначально предполагался такой: получить все блоки в чертеже, проверить на соответствие имени блока (содержит или нет определенные символы), получить точку вставки этого блока, по этой точке вставки вставить другой блок и назначить вставляемому блоку слой.
Код работает когда в чертеже только блоки, если же есть например мультилиния то блоки "проема" не вставляются.
В дальнейшем так же бы хотелось блок проема (а он динамический) вставлять определенных размеров, в зависимости от имени блоков ВВК и ВВП (они статические, по этому не придумал ничего лучше как пойти в лоб и присваивать в зависимости от имени - размеры)
Просьба помочь, так как vba только начинаю осваивать (с помощью чата GPT в том числе - очень неплохо помогает в начинаниях)
--- Код - Visual Basic [Выбрать] ---Sub OTV_SAE() Dim BR As AcadBlockReference Dim blk As AcadBlock Dim name As String Dim pp As Variant Dim targetLayerName As String On Error Resume Next ' Ignore errors temporarily ' Удаляем предыдущие блоки "Проём" For Each BR In ThisDrawing.ModelSpace If TypeName(BR) = "IAcadBlockReference" Then If BR.name = "Проём" Then BR.Delete End If End If Next BR name = BR.name 'расставляю блок отверстия в местах установки КРУГЛЫХ шахт For Each BR In ThisDrawing.ModelSpace If InStr(1, name, "ВВК", vbTextCompare) > 0 Then ' Check if name contains "ВВК" pp = BR.InsertionPoint name = "Проём" Set blk = ThisDrawing.Blocks.Item(name) If Not blk Is Nothing Then ThisDrawing.ModelSpace.InsertBlock pp, name, 1, 1, 1, 0 Else MsgBox "Block 'Проём' not found.", vbExclamation, "Error" End If End If Next BR 'расставляю блок отверстия в местах установки ПРЯМОУГОЛЬНЫХ шахт For Each BR In ThisDrawing.ModelSpace If InStr(1, name, "ВВП", vbTextCompare) > 0 Then ' Check if name contains "ВВП" pp = BR.InsertionPoint name = "Проём" Set blk = ThisDrawing.Blocks.Item(name) If Not blk Is Nothing Then ThisDrawing.ModelSpace.InsertBlock pp, name, 1, 1, 1, 0 Else MsgBox "Block 'Проём' not found.", vbExclamation, "Error" End If End If Next BR 'назначаю блоку отверстия слой "заданий" For Each BR In ThisDrawing.ModelSpace If TypeName(BR) = "IAcadBlockReference" Then name = BR.name targetLayerName = "" If name = "Проём" Then BR.layer = "задание_ОТВЕРСТИЯ" End If End If Next BR MsgBox "Отверстия расставлены" On Error GoTo 0 ' Reset error handlingEnd Sub
Александр Ривилис:
--- Цитата: sae.prc от 21-08-2023, 14:07:23 ---Код работает когда в чертеже только блоки, если же есть например мультилиния то блоки "проема" не вставляются.
--- Конец цитаты ---
Это очевидно. Ты же в циклах
--- Код - Visual Basic [Выбрать] ---For Each BR In ThisDrawing.ModelSpaceпредполагаешь что у тебя в чертеже есть только вставки блоков. BR у тебя должно быть AcadEntity, чтобы можно было пройтись по всем примитивам в Пространстве Модели.
sae.prc:
Александр, благодарю за ответ!
sae.prc:
Подправил код. После исправления типа переменной BR на AcadEntity все работает так как надо. Появился вопрос в зависимости от имени блоков менять свойства динблока "Проем", подскажите как лучше организовать, ввиду того что список типоразмеров велик (прямоуголки от 100х100 до 2000х2000 (и то не предел) с шагом 50). Код как это организовано сейчас (на примере лишь двух размеров)
--- Код - Visual Basic [Выбрать] ---Sub OTV_SAE() Dim BR As AcadEntity Dim blk As AcadBlock Dim dbrp As AcadDynamicBlockReferenceProperty Dim name As String Dim pp As Variant Dim targetLayerName As String Dim blrf As AcadBlockReference On Error Resume Next ' Ignore errors temporarily ' Удаляем предыдущие блоки "Проём" For Each BR In ThisDrawing.ModelSpace If TypeName(BR) = "IAcadBlockReference" Then If BR.name = "Проём" Then BR.Delete End If End If Next BR 'расставляю блок отверстия в местах установки КРУГЛЫХ шахт For Each BR In ThisDrawing.ModelSpace If TypeName(BR) = "IAcadBlockReference" Then name = BR.name If InStr(1, name, "ВВК", vbTextCompare) > 0 Then ' Check if name contains "ВВК" pp = BR.InsertionPoint name = "Проём" Set blk = ThisDrawing.Blocks.Item(name) If Not blk Is Nothing Then ThisDrawing.ModelSpace.InsertBlock pp, name, 1, 1, 1, 0 Else MsgBox "Block 'Проём' not found.", vbExclamation, "Error" End If End If End If Next BR 'расставляю блок отверстия в местах установки ПРЯМОУГОЛЬНЫХ шахт For Each BR In ThisDrawing.ModelSpace If TypeName(BR) = "IAcadBlockReference" Then name = BR.name If name = "ВВП400_200" Then ' pp = BR.InsertionPoint name = "Проём" Set blrf = ThisDrawing.ModelSpace.InsertBlock(pp, name, 1, 1, 1, 0) blrf.layer = "задание_ОТВЕРСТИЯ" If blrf.IsDynamicBlock = True Then props = blrf.GetDynamicBlockProperties For Index = LBound(props) To UBound(props) Set prop = props(Index) If prop.PropertyName = "Ширина" Then prop.Value = 500# ElseIf prop.PropertyName = "Длина/Диаметр" Then prop.Value = 300# End If Next End If ElseIf name = "ВВП500_300" Then pp = BR.InsertionPoint name = "Проём" Set blrf = ThisDrawing.ModelSpace.InsertBlock(pp, name, 1, 1, 1, 0) blrf.layer = "задание_ОТВЕРСТИЯ" If blrf.IsDynamicBlock = True Then props = blrf.GetDynamicBlockProperties For Index = LBound(props) To UBound(props) Set prop = props(Index) If prop.PropertyName = "Ширина" Then prop.Value = 600# ElseIf prop.PropertyName = "Длина/Диаметр" Then prop.Value = 400# End If Next End If ElseIf InStr(1, name, "ВВП", vbTextCompare) > 0 Then pp = BR.InsertionPoint name = "Проём" Set blrf = ThisDrawing.ModelSpace.InsertBlock(pp, name, 1, 1, 1, 0) blrf.layer = "задание_ОТВЕРСТИЯ" End If End If Next BR MsgBox "Отверстия расставлены" On Error GoTo 0 ' Reset error handlingEnd Sub
sae.prc:
Можно ли как то в цикле записать что в текcте [ВВП]#1_#2, извлечь #1 и #2 и блок проема вставить с размерами #1+100 и #2+100?
Навигация
Перейти к полной версии