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 handling
End Sub
