Sub PlotByBlocks() 'Tools -> References-> подключить библиотеку AutoCAD 20XX Type Library
On Error Resume Next
Dim acadApp As AcadApplication
Dim acadDoc As AcadDocument
Dim n As Integer ' ДОБАВИЛ 2
With Sheets("!")
.Activate
n = .Range("B" & 1).Value ' ДОБАВИЛ 2
End With
Set acadApp = GetObject(, "AutoCad.Application")
Set acadDoc = acadApp.ActiveDocument
If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding
End If
Dim objEnt As AcadObject
Dim objBRef As AcadBlockReference
Dim pt1 As Variant
Dim pt2(0 To 1) As Double
Dim i As Integer
Dim varAttributes As Variant ' ДОБАВИЛ
Dim l As Variant ' ДОБАВИЛ
Dim format As String ' ДОБАВИЛ 3
Dim arr() As AcadEntity ' ДОБАВИЛ 3
Dim arr2() As AcadEntity ' ДОБАВИЛ 3
Dim ss As AcadSelectionSet
Set ss = acadDoc.SelectionSets.Item("SS")
If ss Is Nothing Then
Set ss = acadDoc.SelectionSets.Add("SS")
Else
ss.Clear ' если используем сущ. SS то очистить его
End If
ss.SelectonScreen
On Error GoTo 0
i = 0
For Each objEnt In ss
If objEnt.ObjectName = "AcDbBlockReference" Then
ReDim Preserve arr(i)
Set arr(i) = objEnt
i = i + 1
End If
Next
A4к = 0: A3а = 0
A3к = 0: A2а = 0
A2к = 0: A1а = 0
A1к = 0: A0а = 0
A0к = 0
For i = LBound(arr) To UBound(arr)
varAttributes = arr(i).GetAttributes
l = varAttributes(4).TextString
If arr(i).EffectiveName = "А4кшб" Then
'varAttributes = arr(i).GetAttributes
'l = varAttributes(4).TextString
pt1 = arr(i).InsertionPoint
'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
'ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 21000
pt2(1) = pt1(1) + 29700
A4к = A4к + 1
format = "A4к"
PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
ElseIf arr(i).EffectiveName = "ОД" Or arr(i).EffectiveName = "А3ашб" Then
'varAttributes = arr(i).GetAttributes
'l = varAttributes(4).TextString
pt1 = arr(i).InsertionPoint
'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
'ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 42000
pt2(1) = pt1(1) + 29700
A3а = A3а + 1
format = "A3а"
PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
ElseIf arr(i).EffectiveName = "А3кшб" Then
'varAttributes = arr(i).GetAttributes
'l = varAttributes(4).TextString
pt1 = arr(i).InsertionPoint
'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
'ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 29700
pt2(1) = pt1(1) + 42000
A3к = A3к + 1
format = "A3к"
PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
ElseIf arr(i).EffectiveName = "А2ашб" Then
'varAttributes = arr(i).GetAttributes
'l = varAttributes(4).TextString
pt1 = arr(i).InsertionPoint
'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
'ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 59400
pt2(1) = pt1(1) + 42000
A2а = A2а + 1
format = "A2а"
PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
ElseIf arr(i).EffectiveName = "А2кшб" Then
'varAttributes = arr(i).GetAttributes
'l = varAttributes(4).TextString
pt1 = arr(i).InsertionPoint
'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 42000
pt2(1) = pt1(1) + 59400
A2к = A2к + 1
format = "A2к"
PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
ElseIf arr(i).EffectiveName = "А1ашб" Then
'varAttributes = arr(i).GetAttributes
'l = varAttributes(4).TextString
pt1 = arr(i).InsertionPoint
'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
'ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 84100
pt2(1) = pt1(1) + 59400
A1а = A1а + 1
format = "A1а"
PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
ElseIf arr(i).EffectiveName = "А1кшб" Then
'varAttributes = arr(i).GetAttributes
'l = varAttributes(4).TextString
pt1 = arr(i).InsertionPoint
'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
'ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 59400
pt2(1) = pt1(1) + 84100
A1к = A1к + 1
format = "A1к"
PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
ElseIf arr(i).EffectiveName = "А0ашб" Then
'varAttributes = arr(i).GetAttributes
'l = varAttributes(4).TextString
pt1 = arr(i).InsertionPoint
'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 11890
pt2(1) = pt1(1) + 84100
A0а = A0а + 1
format = "A0а"
PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
ElseIf arr(i).EffectiveName = "А0кшб" Then
'varAttributes = arr(i).GetAttributes
'l = varAttributes(4).TextString
pt1 = arr(i).InsertionPoint
'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
'ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 84100
pt2(1) = pt1(1) + 11890
A0к = A0к + 1
format = "A0к"
PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
End If
Next
End Sub
Sub PolyPlot(ByRef acadDoc, strFileName As String, pt1 As Variant, pt2 As Variant, format As String)
Dim Layout As AcadLayout
Set Layout = acadDoc.ActiveLayout
Layout.RefreshPlotDeviceInfo
Layout.ConfigName = "DWG To PDF.pc3"
acadDoc.SetVariable "BACKGROUNDPLOT", 0
If format = "A4к" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A4_(210.00_x_297.00_MM)"
ElseIf format = "A3а" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A3_(420.00_x_297.00_MM)"
ElseIf format = "A3к" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A3_(297.00_x_420.00_MM)"
ElseIf format = "A2а" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A2_(594.00_x_420.00_MM)"
ElseIf format = "A2к" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A2_(420.00_x_594.00_MM)"
ElseIf format = "A1а" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A1_(841.00_x_594.00_MM)"
ElseIf format = "A1к" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A1_(594.00_x_841.00_MM)"
ElseIf format = "A0а" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A0_(1189.00_x_841.00_MM)"
ElseIf format = "A0к" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A0_(841.00_x_1189.00_MM)"
End If
Layout.CenterPlot = True
Layout.PlotRotation = ac0degrees
Layout.StandardScale = acScaleToFit
Layout.StyleSheet = "acad.ctb"
Layout.SetWindowToPlot pt1, pt2
Layout.PlotType = acWindow
acadDoc.Regen acAllViewports
acadDoc.Plot.PlotToFile strFileName
End Sub
