Пакетная печать VBA из листа со многими ВЭ

Автор Тема: Пакетная печать VBA из листа со многими ВЭ  (Прочитано 16179 раз)

0 Пользователей и 1 Гость просматривают эту тему.

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Отступы сделал. Пример прикрепил.
Код отрабатывает печатает только 5-ый лист
Далее ошибка на строке 181 Layout.SetWindowToPlot pt1, pt2 - Недопустимое число элементов в SafeArray
Сам код:
Код - Visual Basic [Выбрать]
  1. Sub PlotByBlocks() 'Tools -> References-> подключить библиотеку AutoCAD 20XX Type Library
  2. On Error Resume Next
  3. Dim acadApp As AcadApplication
  4. Dim acadDoc As AcadDocument
  5. Dim n As Integer ' ДОБАВИЛ 2
  6. With Sheets("!")
  7. .Activate
  8. n = .Range("B" & 1).Value ' ДОБАВИЛ 2
  9. End With
  10. Set acadApp = GetObject(, "AutoCad.Application")
  11. Set acadDoc = acadApp.ActiveDocument
  12. If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
  13.    acadDoc.ActiveSpace = 1     '1 = acModelSpace in early binding
  14. End If
  15.     Dim objEnt As AcadObject
  16.     Dim objBRef As AcadBlockReference
  17.     Dim pt1 As Variant
  18.     Dim pt2(0 To 1) As Double
  19.     Dim i As Integer
  20.     Dim varAttributes As Variant ' ДОБАВИЛ
  21.    Dim l As Variant ' ДОБАВИЛ
  22.    Dim format As String ' ДОБАВИЛ 3
  23.    Dim arr() As AcadEntity ' ДОБАВИЛ 3
  24.    Dim arr2() As AcadEntity ' ДОБАВИЛ 3
  25. Dim ss As AcadSelectionSet
  26. Set ss = acadDoc.SelectionSets.Item("SS")
  27. If ss Is Nothing Then
  28.     Set ss = acadDoc.SelectionSets.Add("SS")
  29. Else
  30.     ss.Clear ' если используем сущ. SS то очистить его
  31. End If
  32. ss.SelectonScreen
  33. On Error GoTo 0
  34.     i = 0
  35.     For Each objEnt In ss
  36.     If objEnt.ObjectName = "AcDbBlockReference" Then
  37.     ReDim Preserve arr(i)
  38.     Set arr(i) = objEnt
  39.     i = i + 1
  40.     End If
  41.     Next
  42.     A4к = 0: A3а = 0
  43.     A3к = 0: A2а = 0
  44.     A2к = 0: A1а = 0
  45.     A1к = 0: A0а = 0
  46.     A0к = 0
  47.         For i = LBound(arr) To UBound(arr)
  48.         varAttributes = arr(i).GetAttributes
  49.         l = varAttributes(4).TextString
  50.         If arr(i).EffectiveName = "А4кшб" Then
  51.             'varAttributes = arr(i).GetAttributes
  52.            'l = varAttributes(4).TextString
  53.            pt1 = arr(i).InsertionPoint
  54.             'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  55.            'ReDim Preserve pt1(0 To 1)
  56.            pt2(0) = pt1(0) + 21000
  57.             pt2(1) = pt1(1) + 29700
  58.             A4к = A4к + 1
  59.             format = "A4к"
  60.             PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  61.             ElseIf arr(i).EffectiveName = "ОД" Or arr(i).EffectiveName = "А3ашб" Then
  62.             'varAttributes = arr(i).GetAttributes
  63.            'l = varAttributes(4).TextString
  64.            pt1 = arr(i).InsertionPoint
  65.             'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  66.            'ReDim Preserve pt1(0 To 1)
  67.            pt2(0) = pt1(0) + 42000
  68.             pt2(1) = pt1(1) + 29700
  69.             A3а = A3а + 1
  70.             format = "A3а"
  71.             PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  72.             ElseIf arr(i).EffectiveName = "А3кшб" Then
  73.             'varAttributes = arr(i).GetAttributes
  74.            'l = varAttributes(4).TextString
  75.            pt1 = arr(i).InsertionPoint
  76.             'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  77.            'ReDim Preserve pt1(0 To 1)
  78.            pt2(0) = pt1(0) + 29700
  79.             pt2(1) = pt1(1) + 42000
  80.             A3к = A3к + 1
  81.             format = "A3к"
  82.             PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  83.             ElseIf arr(i).EffectiveName = "А2ашб" Then
  84.             'varAttributes = arr(i).GetAttributes
  85.            'l = varAttributes(4).TextString
  86.            pt1 = arr(i).InsertionPoint
  87.             'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  88.            'ReDim Preserve pt1(0 To 1)
  89.            pt2(0) = pt1(0) + 59400
  90.             pt2(1) = pt1(1) + 42000
  91.             A2а = A2а + 1
  92.             format = "A2а"
  93.             PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  94.             ElseIf arr(i).EffectiveName = "А2кшб" Then
  95.             'varAttributes = arr(i).GetAttributes
  96.            'l = varAttributes(4).TextString
  97.            pt1 = arr(i).InsertionPoint
  98.             'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  99.            ReDim Preserve pt1(0 To 1)
  100.             pt2(0) = pt1(0) + 42000
  101.             pt2(1) = pt1(1) + 59400
  102.             A2к = A2к + 1
  103.             format = "A2к"
  104.             PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  105.             ElseIf arr(i).EffectiveName = "А1ашб" Then
  106.             'varAttributes = arr(i).GetAttributes
  107.            'l = varAttributes(4).TextString
  108.            pt1 = arr(i).InsertionPoint
  109.             'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  110.            'ReDim Preserve pt1(0 To 1)
  111.            pt2(0) = pt1(0) + 84100
  112.             pt2(1) = pt1(1) + 59400
  113.             A1а = A1а + 1
  114.             format = "A1а"
  115.             PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  116.             ElseIf arr(i).EffectiveName = "А1кшб" Then
  117.             'varAttributes = arr(i).GetAttributes
  118.            'l = varAttributes(4).TextString
  119.            pt1 = arr(i).InsertionPoint
  120.             'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  121.            'ReDim Preserve pt1(0 To 1)
  122.            pt2(0) = pt1(0) + 59400
  123.             pt2(1) = pt1(1) + 84100
  124.             A1к = A1к + 1
  125.             format = "A1к"
  126.             PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  127.             ElseIf arr(i).EffectiveName = "А0ашб" Then
  128.             'varAttributes = arr(i).GetAttributes
  129.            'l = varAttributes(4).TextString
  130.            pt1 = arr(i).InsertionPoint
  131.             'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  132.            ReDim Preserve pt1(0 To 1)
  133.             pt2(0) = pt1(0) + 11890
  134.             pt2(1) = pt1(1) + 84100
  135.             A0а = A0а + 1
  136.             format = "A0а"
  137.             PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  138.             ElseIf arr(i).EffectiveName = "А0кшб" Then
  139.             'varAttributes = arr(i).GetAttributes
  140.            'l = varAttributes(4).TextString
  141.            pt1 = arr(i).InsertionPoint
  142.             'pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  143.            'ReDim Preserve pt1(0 To 1)
  144.            pt2(0) = pt1(0) + 84100
  145.             pt2(1) = pt1(1) + 11890
  146.             A0к = A0к + 1
  147.             format = "A0к"
  148.             PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  149.         End If
  150.         Next
  151. End Sub
  152. Sub PolyPlot(ByRef acadDoc, strFileName As String, pt1 As Variant, pt2 As Variant, format As String)
  153.     Dim Layout As AcadLayout
  154.     Set Layout = acadDoc.ActiveLayout
  155.     Layout.RefreshPlotDeviceInfo
  156.     Layout.ConfigName = "DWG To PDF.pc3"
  157.     acadDoc.SetVariable "BACKGROUNDPLOT", 0
  158.     If format = "A4к" Then
  159.     Layout.CanonicalMediaName = "ISO_full_bleed_A4_(210.00_x_297.00_MM)"
  160.     ElseIf format = "A3а" Then
  161.     Layout.CanonicalMediaName = "ISO_full_bleed_A3_(420.00_x_297.00_MM)"
  162.     ElseIf format = "A3к" Then
  163.     Layout.CanonicalMediaName = "ISO_full_bleed_A3_(297.00_x_420.00_MM)"
  164.     ElseIf format = "A2а" Then
  165.     Layout.CanonicalMediaName = "ISO_full_bleed_A2_(594.00_x_420.00_MM)"
  166.     ElseIf format = "A2к" Then
  167.     Layout.CanonicalMediaName = "ISO_full_bleed_A2_(420.00_x_594.00_MM)"
  168.     ElseIf format = "A1а" Then
  169.     Layout.CanonicalMediaName = "ISO_full_bleed_A1_(841.00_x_594.00_MM)"
  170.     ElseIf format = "A1к" Then
  171.     Layout.CanonicalMediaName = "ISO_full_bleed_A1_(594.00_x_841.00_MM)"
  172.     ElseIf format = "A0а" Then
  173.     Layout.CanonicalMediaName = "ISO_full_bleed_A0_(1189.00_x_841.00_MM)"
  174.     ElseIf format = "A0к" Then
  175.     Layout.CanonicalMediaName = "ISO_full_bleed_A0_(841.00_x_1189.00_MM)"
  176.     End If
  177.     Layout.CenterPlot = True
  178.     Layout.PlotRotation = ac0degrees
  179.     Layout.StandardScale = acScaleToFit
  180.     Layout.StyleSheet = "acad.ctb"
  181.     Layout.SetWindowToPlot pt1, pt2
  182.     Layout.PlotType = acWindow
  183.     acadDoc.Regen acAllViewports
  184.     acadDoc.Plot.PlotToFile strFileName
  185. End Sub

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
блин не сразу заметил что Вы скинули откорректированный код.
Вот Вы себе вообще не желаете жизнь упрощать? накой черт понадобилось копировать команду печати по всем блокам иф???

Удалите весь код и начните писать с начала, а то Вы в край запутались