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 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
Set objBRef = objEnt
varAttributes = objBRef.GetAttributes
l = varAttributes(4).TextString
A4к = 0
A3а = 0
If objBRef.EffectiveName = "А4кшб" Or objBRef.EffectiveName = "Титул" Then
pt1 = objBRef.InsertionPoint
varAttributes = objBRef.GetAttributes
l = varAttributes(4).TextString
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 21000
pt2(1) = pt1(1) + 29700
A4к = A4к + 1
format = "A4к"
ElseIf objBRef.EffectiveName = "ОД" Or objBRef.EffectiveName = "А3ашб" Then
pt1 = objBRef.InsertionPoint
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 42000
pt2(1) = pt1(1) + 29700
A3а = A3а + 1
format = "A3а"
i = i + 1
PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
End If
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)"
End If
Layout.CenterPlot = True
Layout.PlotRotation = ac0degrees
Layout.StandardScale = acScaleToFit
Layout.StyleSheet = "acad.ctb"
pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False) ' добавил по статье https://adn-cis.org/pechat-granicz-okna-pri-pomoshhi-vba.html
pt2 = acadDoc.Utility.TranslateCoordinates(pt2, acWorld, acDisplayDCS, False) ' добавил по статье https://adn-cis.org/pechat-granicz-okna-pri-pomoshhi-vba.html
Layout.SetWindowToPlot pt1, pt2
Layout.PlotType = acWindow
acadDoc.Regen acAllViewports
acadDoc.Plot.PlotToFile strFileName
End Sub
