ADN Club > VBA
Макрос вставки блока в точки вставки имеющихся в чертеже блоков
sae.prc:
Попробовал вариант с использование словаря, значения по ключу не передаются на динамический блок, в чем может быть проблема
--- Код - Visual Basic [Выбрать] ---Sub OTV_SAEv1_4() Dim BR As AcadEntity Dim blk As AcadBlock Dim name As String Dim pp As Variant Dim targetLayerName As String Dim blrf As AcadBlockReference Dim sizes_bbk As New Scripting.Dictionary ' создаем словарь круглых типоразмеров ' заполняем словарь круглых типоразмеров sizes_bbk.Add "ВВК100", 200 sizes_bbk.Add "ВВК125", 200 sizes_bbk.Add "ВВК160", 250 sizes_bbk.Add "ВВК200", 300 sizes_bbk.Add "ВВК250", 350 sizes_bbk.Add "ВВК315", 400 sizes_bbk.Add "ВВК355", 450 sizes_bbk.Add "ВВК400", 500 sizes_bbk.Add "ВВК450", 550 sizes_bbk.Add "ВВК500", 600 sizes_bbk.Add "ВВК560", 650 sizes_bbk.Add "ВВК630", 700 sizes_bbk.Add "ВВК710", 800 sizes_bbk.Add "ВВК800", 900 sizes_bbk.Add "ВВК900", 1000 sizes_bbk.Add "ВВК1000", 1100 sizes_bbk.Add "ВВК1120", 1200 sizes_bbk.Add "ВВК1250", 1350 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 sizes_bbk.Exists(name) = True Then pp = BR.InsertionPoint name = "Проём" Set blrf = ThisDrawing.ModelSpace.InsertBlock(pp, name, 1, 1, 1, 0) blrf.layer = "задание_ОТВЕРСТИЯ" If blrf.IsDynamicBlock = True Then Dim size_bbk_Value As Double size_bbk_Value = sizes_bbk(name) props = blrf.GetDynamicBlockProperties For Index = LBound(props) To UBound(props) Set prop = props(Index) If prop.PropertyName = "Ширина" Then prop.Value = size_bbk_Value ElseIf prop.PropertyName = "Длина/Диаметр" Then prop.Value = size_bbk_Value 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
sae.prc:
В итоге получилось так, код работает, отверстия ставятся, не знаю на сколько корректный код, но мне как новичку пока важно что он рабочий
--- Код - Visual Basic [Выбрать] ---Sub OTV_SAEv1_4() Dim BR As AcadEntity Dim blk As AcadBlock Dim name As String Dim pp As Variant Dim targetLayerName As String Dim blrf As AcadBlockReference Dim ro_angle Dim sizes_bbk As New Scripting.Dictionary ' создаем словарь круглых типоразмеров шахт Dim sizes_bbp As New Scripting.Dictionary ' создаем словарь прямоугольных типоразмеров шахт Dim width As Variant Dim height As Variant Dim widths As Variant Dim heights As Variant widths = Array(100, 150, 200, 250, 300, 350, 400, 450, 500, 550, 600, 650, 700, 750, 800, 850, 900, 950, 1000, 1050, 1100, 1150, 1200, 1250, 1300, 1350, 1400, 1450, 1500, 1550, 1600, 1650, 1700, 1750, 1800, 1850, 1900, 1950, 2000) heights = Array(100, 150, 200, 250, 300, 350, 400, 450, 500, 550, 600, 650, 700, 750, 800, 850, 900, 950, 1000, 1050, 1100, 1150, 1200, 1250, 1300, 1350, 1400, 1450, 1500, 1550, 1600, 1650, 1700, 1750, 1800, 1850, 1900, 1950, 2000) ' заполняем словарь круглых типоразмеров sizes_bbk.Add "ВВК100", 200 sizes_bbk.Add "ВВК125", 200 sizes_bbk.Add "ВВК160", 250 sizes_bbk.Add "ВВК200", 300 sizes_bbk.Add "ВВК250", 350 sizes_bbk.Add "ВВК315", 400 sizes_bbk.Add "ВВК355", 450 sizes_bbk.Add "ВВК400", 500 sizes_bbk.Add "ВВК450", 550 sizes_bbk.Add "ВВК500", 600 sizes_bbk.Add "ВВК560", 650 sizes_bbk.Add "ВВК630", 700 sizes_bbk.Add "ВВК710", 800 sizes_bbk.Add "ВВК800", 900 sizes_bbk.Add "ВВК900", 1000 sizes_bbk.Add "ВВК1000", 1100 sizes_bbk.Add "ВВК1120", 1200 sizes_bbk.Add "ВВК1250", 1350 ' заполняем словарь прямоугольных типоразмеров For Each width In widths For Each height In heights sizes_bbp.Add "ВВП" & CStr(width) & "_" & CStr(height), Array(width + 100, height + 100) Next height Next width 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 sizes_bbk.Exists(name) Then pp = BR.InsertionPoint name_pr = "Проём" Set blrf = ThisDrawing.ModelSpace.InsertBlock(pp, name_pr, 1, 1, 1, 0) blrf.layer = "задание_ОТВЕРСТИЯ" If blrf.IsDynamicBlock = True Then Dim size_bbk_Value As Double size_bbk_Value = sizes_bbk(name) props = blrf.GetDynamicBlockProperties For Index = LBound(props) To UBound(props) Set prop = props(Index) If prop.PropertyName = "Ширина" Then prop.Value = size_bbk_Value ElseIf prop.PropertyName = "Длина/Диаметр" Then prop.Value = size_bbk_Value 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 'расставляю блок отверстия в местах установки ПРЯМОУГОЛЬНЫХ шахт For Each BR In ThisDrawing.ModelSpace If TypeName(BR) = "IAcadBlockReference" Then name = BR.name If sizes_bbp.Exists(name) Then pp = BR.InsertionPoint name_pr = "Проём" 'получение угла поворота блока ВВП ro_angle = BR.Rotation Set blrf = ThisDrawing.ModelSpace.InsertBlock(pp, name_pr, 1, 1, 1, ro_angle) blrf.layer = "задание_ОТВЕРСТИЯ" If blrf.IsDynamicBlock = True Then Dim size_bbp_values As Variant Dim pprops As Variant Dim pprop As Variant pprops = blrf.GetDynamicBlockProperties size_bbp_values = sizes_bbp(name) For Index = LBound(pprops) To UBound(pprops) Set pprop = pprops(Index) If pprop.PropertyName = "Ширина" Then pprop.Value = CDbl(size_bbp_values(0)) ElseIf pprop.PropertyName = "Длина/Диаметр" Then pprop.Value = CDbl(size_bbp_values(1)) 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 If blrf Is Nothing Then ' Проверка наличия блока "Проем" в чертеже MsgBox "Block 'Проём' not found.", vbExclamation, "Error" Else MsgBox "Отверстия расставлены" End If On Error GoTo 0 ' Reset error handlingEnd Sub
Навигация
Перейти к полной версии