Sub PlotByBlocks()
'Tools -> References-> ïîäêëþ÷èòü áèáëèîòåêó AutoCAD 20XX Type Library
On Error Resume Next
Dim acadApp As AcadApplication
Dim acadDoc As AcadDocument
'Ïîëó÷àåì ññûëêó íà ïðèëîæåíèå àâòîêàäà
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 ss As AcadSelectionSet
'Ïðîâåðèòü ñóùåñòâóåò ëè íàáîð ñ òàêèì èìåíåì
Set ss = acadDoc.SelectionSets.Item("SS")
'åñëè íå ñóùåñòâóåò òî ñîçäàåì
If ss Is Nothing Then
Set ss = acadDoc.SelectionSets.Add("SS")
End If
ss.SelectonScreen
On Error GoTo 0
i = 0
For Each objEnt In ss
'Ó âàñ áûëî íå ïðàâèëüíîå èìÿ
If objEnt.ObjectName = "AcDbBlockReference" Then
Set objBRef = objEnt
If objBRef.EffectiveName = "À1àøá" Then
pt1 = objBRef.InsertionPoint
varAttributes = objBRef.GetAttributes ' ÄÎÁÀÂÈË
l = varAttributes(4).TextString ' ÄÎÁÀÂÈË
'pt1 = ThisDrawing.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
ReDim Preserve pt1(0 To 1)
pt2(0) = pt1(0) + 84100
pt2(1) = pt1(1) + 59400
i = i + 1
'òàê êàê êîä çàïóñêàåòñÿ èç Åêñåëÿ, ìû íå ìîæåì ññûëàòüñÿ íà ThisDrawling, íóæíî â ïðîöåäóðó PolyPlot ïåðåäàòü ññûëêó íà äîêóìåíò àâòîêàäà
'ActiveWorkbook.Path -- ïóòü âàøåãî åêñåëÿ
PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(l), pt1, pt2 ' æåëàòåëüíî ïî ïóòè ôàéëà Excel ñîõðàíèòü â ïàïêó èç ÿ÷åéêè B1
End If
End If
Next
End Sub
Sub PolyPlot(ByRef acadDoc, strFileName As String, pt1 As Variant, pt2 As Variant)
Dim Layout As AcadLayout
'çàìåíà ThisDrawling íà ññûëêó ÷åðòåæà â àâòîêàä
Set Layout = acadDoc.ActiveLayout
Layout.RefreshPlotDeviceInfo
Layout.ConfigName = "DWG To PDF.pc3"
acadDoc.SetVariable "BACKGROUNDPLOT", 0
'â âèäåî Ìàêñèì Ìàðêåâè÷ àêöåíòèðîâàë ÷òî èìÿ ôîðìàòà äîëæíî áûòü íà àíãëèéñêîì ñ çàìåíîé ïðîáåëîâ íà íèæíåå ïîä÷åðêèâàíèå
Layout.CanonicalMediaName = "ISO_full_bleed_A1_(841.00_x_594.00_MM)"
Layout.CenterPlot = True
Layout.PlotRotation = ac0degrees
Layout.StandardScale = acScaleToFit
Layout.StyleSheet = "acad.ctb"
Layout.SetWindowToPlot pt1, pt2
Layout.PlotType = acWindow
'çàìåíà ThisDrawling íà ññûëêó ÷åðòåæà â àâòîêàä
acadDoc.Regen acAllViewports
acadDoc.Plot.PlotToFile strFileName
End Sub
