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
If objBRef.EffectiveName = "А4кшб" Or objBRef.EffectiveName = "ОУ" 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
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
format = "A3а"
ElseIf objBRef.EffectiveName = "А3кшб" Then
pt1 = objBRef.InsertionPoint
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 29700
pt2(1) = pt1(1) + 42000
format = "A3к"
ElseIf objBRef.EffectiveName = "А2ашб" Then
pt1 = objBRef.InsertionPoint
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 59400
pt2(1) = pt1(1) + 42000
format = "A2а"
ElseIf objBRef.EffectiveName = "А2кшб" Then
pt1 = objBRef.InsertionPoint
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 42000
pt2(1) = pt1(1) + 59400
format = "A2к"
ElseIf objBRef.EffectiveName = "А1ашб" Then
pt1 = objBRef.InsertionPoint
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 84100
pt2(1) = pt1(1) + 59400
format = "A1а"
ElseIf objBRef.EffectiveName = "А1кшб" Then
pt1 = objBRef.InsertionPoint
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 59400
pt2(1) = pt1(1) + 84100
format = "A1к"
ElseIf objBRef.EffectiveName = "А0ашб" Then
pt1 = objBRef.InsertionPoint
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 11890
pt2(1) = pt1(1) + 84100
format = "A0а"
ElseIf objBRef.EffectiveName = "А0кшб" Then
pt1 = objBRef.InsertionPoint
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 84100
pt2(1) = pt1(1) + 11890
format = "A0к"
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)
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)"
If format = "A3а" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A3_(420.00_x_297.00_MM)"
If format = "A3к" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A3_(297.00_x_420.00_MM)"
If format = "A2а" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A2_(594.00_x_420.00_MM)"
If format = "A2к" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A2_(420.00_x_594.00_MM)"
If format = "A1а" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A1_(841.00_x_594.00_MM)"
If format = "A1к" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A1_(594.00_x_841.00_MM)"
If format = "A0а" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A0_(1189.00_x_841.00_MM)"
If format = "A0к" Then
Layout.CanonicalMediaName = "ISO_full_bleed_A0_(841.00_x_1189.00_MM)"
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
