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

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

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

Оффлайн Alexdt20gtАвтор темы

  • ADN OPEN
  • Сообщений: 2
  • Карма: 0
Добрый день! Только начал изучать VBA, ваши уроки очень помогают! Но возник вопрос следующего характера:
Пакетная печать по блоку прекрасно работает в пространстве модели, но иногда приходят чертежи выполненные в "одном листе". То есть множество форматок раскидано на листе 1 и создано множество ВЭ.При запуске макроса печать  из пространства листе ничего не происходит, но стоит один лист напечатать из листа через рамку как макрос находит и выводит на печать все указанные форматы на данном листе.
Через MsgBox определил что "вылетает" после прохождения строки выбора формата листа. Как я понимаю это связанно с настройками листа заданными при его создании, а точнее тем что по умолчанию выставлена печать "лист".
Хотя в макросе и идет переопределение способа печати на рамку, печатать он отказывается

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Alexdt20gt, приветствую на форуме!
Топик отделил от исходной темы - к обсуждению видеоуроков по VBA вопрос не имеет отношения. Настоятельно рекомендую привести свой (или используемый) код и пример файла. Из файла dwg можно предварительно удалить всю секретную информацию и выполнить его очистку.
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Максим Маркевич

  • ADN Club
  • ****
  • Сообщений: 254
  • Карма: 29
  • Skype: evthisrel
При запуске макроса печать  из пространства листе ничего не происходит
Попробуй вот так:
Код - Visual Basic [Выбрать]
  1. Sub PlotByBlocks()
  2.  
  3.     Dim objEnt As AcadEntity
  4.     Dim objBRef As AcadBlockReference
  5.     Dim pt1 As Variant
  6.     Dim pt2(0 To 1) As Double
  7.     Dim i As Integer
  8.    
  9.     ' Создаем выбор рамкой
  10.    On Error Resume Next
  11.     ThisDrawing.SelectionSets("SS").Delete
  12.     Set ss = ThisDrawing.SelectionSets.Add("SS")
  13.     ss.SelectOnScreen
  14.        
  15.     ' Работаем, если имя блока А1
  16.    i = 0
  17.     For Each objEnt In ss
  18.     If objEnt.ObjectName = "AcDbBlockReference" Then
  19.     Set objBRef = objEnt
  20.         If objBRef.EffectiveName = "A1" Then
  21.             pt1 = objBRef.insertionPoint
  22.             pt1 = ThisDrawing.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  23.             ReDim Preserve pt1(0 To 1)
  24.             pt2(0) = pt1(0) + 841
  25.             pt2(1) = pt1(1) + 594
  26.             i = i + 1
  27.             PolyPlot "c:\Users\evthi\Desktop\Тест" + CStr(i), pt1, pt2
  28.         End If
  29.     End If
  30.     Next
  31.    
  32. End Sub
  33. Sub PolyPlot(strFileName As String, pt1 As Variant, pt2 As Variant)
  34.  
  35.     ' Декларируем
  36.    Dim Layout As AcadLayout
  37.          
  38.     ' Устанавливаем
  39.    Set Layout = ThisDrawing.ActiveLayout
  40.        
  41.     Layout.RefreshPlotDeviceInfo
  42.            
  43.     ' Настройка печати
  44.    Layout.ConfigName = "DWG to PDF.pc3"
  45.     Layout.CanonicalMediaName = "ISO_full_bleed_A1_(594.00_x_841.00_MM)"
  46.     'Layout.CenterPlot = True
  47.    Layout.PlotRotation = ac90degrees
  48.     Layout.StandardScale = acScaleToFit
  49.     Layout.StyleSheet = "acad.ctb"
  50.  
  51.     ' Устанавливаем рамки и тип окошка
  52.    Layout.SetWindowToPlot pt1, pt2
  53.     Layout.PlotType = acWindow
  54.    
  55.     ' Отправляем на печать
  56.    ThisDrawing.Regen acAllViewports
  57.     ThisDrawing.Plot.PlotToFile strFileName
  58.        
  59. End Sub

Оффлайн Alexdt20gtАвтор темы

  • ADN OPEN
  • Сообщений: 2
  • Карма: 0
Добрый день! Побывал такой вариант, результата нет.
Так же побывал
    'Layout.CenterPlot = True
    'Layout.PlotRotation = ac90degrees
печатать отказывается.
Мне кажется это связано с "особым" порядком задания параметров в пространстве листа (если он есть).
Параллельно анализирую код !Plot_U там проблема решается сменой пространства ModelSpace на PaperSpace, но в нашем (точнее вашем) коде пространство задано более универсально и все работает, но при условии выпуска 1 листа рамкой вручную. Продолжаю разбираться. Спасибо за быстрый ответ

Оффлайн Пашин Евгений

  • ADN PRO
  • *
  • Сообщений: 662
  • Карма: 12
  • Skype: pashin.evgeniy
Alexdt20gt, добрый день! Задача будет решена быстрее, если Вы приложите файл чертежа с рамками в листах.

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Во вложении пример в dwg с блоком! и файл Excel с кодом - но не работает потому что не умею. Прикрепленный архив
В файле dwg блок есть. Должно по нажатию кнопки активировать кад, выделить мышью зону должен пользователь и напечатать в pdf все блоки. Желательно создать по дороге папку по пути файла эксель и сохранить туда pdf
Помогите разобраться, плиз!

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Я написал комментарии по местам где были ошибки

Желательно просмотреть уроки отсюда: https://adn-cis.org/forum/index.php?topic=7270.0

Код - Visual Basic [Выбрать]
  1. Sub PlotByBlocks()
  2. 'Tools -> References-> подключить библиотеку AutoCAD 20XX Type Library
  3. '
  4. '
  5. Dim acadApp As AcadApplication
  6. Dim acadDoc As AcadDocument
  7.  
  8. 'Получаем ссылку на приложение автокада
  9. Set acadApp = GetObject(, "AutoCad.Application")
  10. Set acadDoc = acadApp.ActiveDocument
  11.  
  12. If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
  13.    acadDoc.ActiveSpace = 1     '1 = acModelSpace in early binding
  14. End If
  15.  
  16.     Dim objEnt As AcadObject
  17.     Dim objBRef As AcadBlockReference
  18.     Dim pt1 As Variant
  19.     Dim pt2(0 To 1) As Double
  20.     Dim i As Integer
  21.  
  22. Dim ss As AcadSelectionSet
  23. 'Проверить существует ли  набор с таким именем
  24. Set ss = acadDoc.SelectionSets.Item("SS")
  25. 'если не существует то создаем
  26. If ss Is Nothing Then
  27.     Set ss = acadDoc.SelectionSets.Add("SS")
  28. End If
  29.  
  30. ss.SelectonScreen
  31.  
  32. On Error Resume Next
  33.     i = 0
  34.     For Each objEnt In ss
  35.     'У вас было  не правильное имя
  36.    If objEnt.ObjectName = "AcDbBlockReference" Then
  37.     Set objBRef = objEnt
  38.         If objBRef.EffectiveName = "А1ашб" Then
  39.         pt1 = objBRef.InsertionPoint
  40.         pt1 = ThisDrawing.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  41.         ReDim Preserve pt1(0 To 1)
  42.         pt2(0) = pt1(0) + 84100
  43.         pt2(1) = pt1(1) + 59400
  44.         i = i + 1
  45.         'так как код запускается из Екселя, мы не можем ссылаться на  ThisDrawling, нужно в процедуру PolyPlot передать ссылку на документ автокада
  46.        'ActiveWorkbook.Path -- путь вашего екселя
  47.        PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(i), pt1, pt2 ' желательно по пути файла Excel сохранить в папку из ячейки B1
  48.        End If
  49.     End If
  50.     Next
  51. End Sub
  52. Sub PolyPlot(ByRef acadDoc, strFileName As String, pt1 As Variant, pt2 As Variant)
  53.     Dim Layout As AcadLayout
  54.     'замена ThisDrawling на ссылку чертежа в автокад
  55.    Set Layout = acadDoc.ActiveLayout
  56.     Layout.RefreshPlotDeviceInfo
  57.     Layout.ConfigName = "DWG To PDF.pc3"
  58.    
  59.         'в видео Максим Маркевич акцентировал что имя формата должно быть на английском с заменой пробелов на нижнее подчеркивание
  60.    Layout.CanonicalMediaName = "ISO_full_bleed_A1_(841.00_x_594.00_MM)"
  61.     Layout.CenterPlot = True
  62.     Layout.PlotRotation = ac0degrees
  63.     Layout.StandardScale = acScaleToFit
  64.     Layout.StyleSheet = "acad.ctb"
  65.     Layout.SetWindowToPlot pt1, pt2
  66.     Layout.PlotType = acWindow
  67.    
  68.     'замена ThisDrawling на ссылку чертежа в автокад
  69.    acadDoc.Regen acAllViewports
  70.     acadDoc.Plot.PlotToFile strFileName
  71. End Sub
  72.  
  73.  

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Подключил 2017 библиотеку
Set ss = acadDoc.SelectionSets.Item("SS") ' здесь дает ошибку: Run-time error '-2145386476 (80200014)': Ключ не найден

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Забил откорректировать. Перенесите 32 строку в самое начало

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
появляется файл plot.log
Пдф не появляются

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
На моем компьютере код исполнился и отпечатал ПДФ.
Поэтому проблема может быть в каких нибудь настройках в вашем автокаде может.
Умеете запускать пошаговую отладку? Нажимайте клавишу F8 - одно нажатие один шаг программы.
Откройте окно locals  на вкладке View - тут можно смотреть значения переменных по ходу исполнения кода

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Вот перенес On Error Resume Next
Распечатался один только лист 1.pdf Листы 2 и 3 не появились. Довольно таки долго в фоновом режиме он печатал этот лист
Поглядите код в модуле может что-то не так сделал?
Еще раз попробовал пдф 1 лист а должно быть 3

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Отпечатал без проблем)
может у вас стоит галочка "печатать в фоновом режиме"?
попробуйте прикрепленный ексель, я там дописал:
"acadDoc.SetVariable "BACKGROUNDPLOT", 0 "    - эта строка убирает печать в фоновом режиме

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Спасибо вам огромное !!!!!!!!
Работает прекрасно.
1. Вопрос если к названию нужно добавить цифру из ячейки B1 что надо в имени переписать. Чтоб было: [B1].А1.1 [B1].А1.2 и [B1].А1.3
2. Вопрос если несколько форматов в модели допустим А4 и А1
нужно добавить ElseIf objBRef.EffectiveName = "А4" Then и прописать к нему точки.
 А как поменять тогда формат куда печатать?

Новая проблема если больше блоков:
на строке For Each objEnt In ss
ошибка Run-time error '-214748113 (8000ffff)' :
Automation error
Разрушительный сбой

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Выше я дал Вам ссылку на тему с видео уроками от Максима Маркевича, там в самом начале разбирается вопрос как считывать информацию из ячейки екселя.
Что касается разных форматов, то экспериментируйте, первые результаты уже есть у Вас, а там на сколько фантазии хватит накрутить, не думаю что есть единственно верный вариант.
Я б рекомендовал разделять на под процедуры, не писать одну огромную простыню

Используйте пошаговую отладко и смотрите окно Locals. У Вас будет еще очень много ошибок, нужно выработать подход к их решению

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Начал просмотр видео уроков
Печатает он конечно не понял по какой логике порядок.
В имя файла пдф атрибут Лист из блока можно как-то посадить вместо CStr(i) с шагом 1 ?
Объявил Dim varAttributes As Variant и Dim l As Variant
 varAttributes = objBRef.GetAttributes ' ДОБАВИЛ
l = varAttributes(4).TextString ' ДОБАВИЛ
Ругается на имя
Код - Visual Basic [Выбрать]
  1. Sub PlotByBlocks()
  2. 'Tools -> References-> ïîäêëþ÷èòü áèáëèîòåêó AutoCAD 20XX Type Library
  3. On Error Resume Next
  4. Dim acadApp As AcadApplication
  5. Dim acadDoc As AcadDocument
  6. 'Ïîëó÷àåì ññûëêó íà ïðèëîæåíèå àâòîêàäà
  7. Set acadApp = GetObject(, "AutoCad.Application")
  8. Set acadDoc = acadApp.ActiveDocument
  9. If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
  10.    acadDoc.ActiveSpace = 1     '1 = acModelSpace in early binding
  11. End If
  12.     Dim objEnt As AcadObject
  13.     Dim objBRef As AcadBlockReference
  14.     Dim pt1 As Variant
  15.     Dim pt2(0 To 1) As Double
  16.     Dim i As Integer
  17.     Dim varAttributes As Variant ' ÄÎÁÀÂÈË
  18.    Dim l As Variant ' ÄÎÁÀÂÈË
  19. Dim ss As AcadSelectionSet
  20. 'Ïðîâåðèòü ñóùåñòâóåò ëè  íàáîð ñ òàêèì èìåíåì
  21. Set ss = acadDoc.SelectionSets.Item("SS")
  22. 'åñëè íå ñóùåñòâóåò òî ñîçäàåì
  23. If ss Is Nothing Then
  24.     Set ss = acadDoc.SelectionSets.Add("SS")
  25. End If
  26. ss.SelectonScreen
  27. On Error GoTo 0
  28.     i = 0
  29.     For Each objEnt In ss
  30.     'Ó âàñ áûëî  íå ïðàâèëüíîå èìÿ
  31.    If objEnt.ObjectName = "AcDbBlockReference" Then
  32.     Set objBRef = objEnt
  33.         If objBRef.EffectiveName = "À1àøá" Then
  34.         pt1 = objBRef.InsertionPoint
  35.         varAttributes = objBRef.GetAttributes ' ÄÎÁÀÂÈË
  36.        l = varAttributes(4).TextString ' ÄÎÁÀÂÈË
  37.        'pt1 = ThisDrawing.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  38.        ReDim Preserve pt1(0 To 1)
  39.         pt2(0) = pt1(0) + 84100
  40.         pt2(1) = pt1(1) + 59400
  41.         i = i + 1
  42.         'òàê êàê êîä çàïóñêàåòñÿ èç Åêñåëÿ, ìû íå ìîæåì ññûëàòüñÿ íà  ThisDrawling, íóæíî â ïðîöåäóðó PolyPlot ïåðåäàòü ññûëêó íà äîêóìåíò àâòîêàäà
  43.        'ActiveWorkbook.Path -- ïóòü âàøåãî åêñåëÿ
  44.        PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(l), pt1, pt2 ' æåëàòåëüíî ïî ïóòè ôàéëà Excel ñîõðàíèòü â ïàïêó èç ÿ÷åéêè B1
  45.        End If
  46.     End If
  47.     Next
  48. End Sub
  49. Sub PolyPlot(ByRef acadDoc, strFileName As String, pt1 As Variant, pt2 As Variant)
  50.     Dim Layout As AcadLayout
  51.     'çàìåíà ThisDrawling íà ññûëêó ÷åðòåæà â àâòîêàä
  52.    Set Layout = acadDoc.ActiveLayout
  53.     Layout.RefreshPlotDeviceInfo
  54.     Layout.ConfigName = "DWG To PDF.pc3"
  55.     acadDoc.SetVariable "BACKGROUNDPLOT", 0
  56.    
  57.         'â âèäåî Ìàêñèì Ìàðêåâè÷ àêöåíòèðîâàë ÷òî èìÿ ôîðìàòà äîëæíî áûòü íà àíãëèéñêîì ñ çàìåíîé ïðîáåëîâ íà íèæíåå ïîä÷åðêèâàíèå
  58.    Layout.CanonicalMediaName = "ISO_full_bleed_A1_(841.00_x_594.00_MM)"
  59.     Layout.CenterPlot = True
  60.     Layout.PlotRotation = ac0degrees
  61.     Layout.StandardScale = acScaleToFit
  62.     Layout.StyleSheet = "acad.ctb"
  63.     Layout.SetWindowToPlot pt1, pt2
  64.     Layout.PlotType = acWindow
  65.    
  66.     'çàìåíà ThisDrawling íà ññûëêó ÷åðòåæà â àâòîêàä
  67.    acadDoc.Regen acAllViewports
  68.     acadDoc.Plot.PlotToFile strFileName
  69. End Sub
  70.  
Атрибут забрал но он почему-то отображается как \W0.9000;1 - а должно быть просто значение 1

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6

Ну они у вас в блоке так и записаны, это скорее всего какая то управляющая последовательность, типа "выравнивание по середине", надо гуглить



Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Это принудительно назначенная ширина для многострочного текста. Снимай форматирование исходного объекта. - так пишут в гугле сейчас поробую.
А можно как-то отсечь из названия 9 символов и начать с десятого ? - так получается недопустимое имя

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Поищите функции VBA для работы с текстовыми значениями.
И через комбинацию функций Len() b Rigth() можно будет отсечь лишнее

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Файл был странный какой-то переделал блок исчезла эта мешающая запись из атрибута
В этом коде думаю нужно еще один блок все таки вводить для блока с книжным расположением для имени блока "А1кшб" при помощи ElseIf, но как во второй части кода тогда выбрать ориентацию тогда
Если это получится то модулей писать придется в 2 раза меньше

Еще вопрос возник. Как добавить еще имя блока сюда If objBRef.EffectiveName = "А1ашб" Then (или "А1а" или "А1ашм")

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Timofeev,
Перед копированием VBA-кода переключай раскладку клавиатуру на русскую. Тогда вместо абракадабры будет нормальный текст.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Александр, принял

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Ничего не делал особо выгрузилось пару раз - потом перестало
Опять я что-то сломал - ошибка на строке
For Each objEnt In ss
ошибка Run-time error '-214748113 (8000ffff)' :
Automation error
Разрушительный сбой

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Timofeev,
Возможно ss пустой, т.е. ничего не выбрано.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Тут не екселька нужна а чертеж и еще бы принтскрин окна Locals на момент ошибки


И еще надо бы добавить очистку существующего селекшн сета
Код - Visual Basic [Выбрать]
  1. 'Проверить существует ли  набор с таким именем
  2. Set ss = acadDoc.SelectionSets.Item("SS")
  3. 'если не существует то создаем
  4. If ss Is Nothing Then
  5.     Set ss = acadDoc.SelectionSets.Add("SS")
  6. Else
  7.     ss.Clear ' если используем сущ. SS то очистить его
  8. End If


а блок у Вас действительно странный, если зайти в редактор блока то там нет аттрибутов.

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
а блок у Вас действительно странный, если зайти в редактор блока то там нет аттрибутов.
Блок действительно не вполне законный с точки зрения AutoCAD - в определении блока нет определений атрибутов, а во вставке блока есть атрибуты.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Добавил переменную для взятия имени с листа Эксель
Код - Visual Basic [Выбрать]
  1. Dim n As Integer ' ДОБАВИЛ 2
  2. With Sheets("!")
  3. .Activate
  4. n = .Range("B" & 1).Value ' ДОБАВИЛ 2
  5. End With

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Как бы обратится по имени атрибута "ЛИСТ", а не по номеру он может быть на разных местах в блоках
varAttributes = objBRef.GetAttributes
l = varAttributes(4).TextString

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Пробежаться циклом по коллекции атрибутов сравнивая TagString, опять же Максим это показывает в роликах :)

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
За 1 день все это успеть понять и отсмотреть сложно достаточно, но буду стараться и писать тоже буду много затык  почти в каждой строчке кода по мере его насыщения
С циклом нашел пробег по атрибутам вроде:
Код - Visual Basic [Выбрать]
  1. For j = LBound(varAttributes) To UBound(varAttributes)
  2. If varAttributes(j).TagString = "ЛИСТ" Then
  3. l = = varAttributes(j).TextString
  4. End If
Правильно я понял?
« Последнее редактирование: 14-01-2021, 15:57:29 от Александр Ривилис »

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Ага, этот отрывок.

Пройдитесь пошагово по скрипту. После строчки: varAttributes = objBRef.GetAttributes откройте Locals и раскройте плюсик у varAttributes.
Вы увидите сколько элементов в массиве, из чего состоит каждый элемент, что такое TagString,TextString. Мне очень помогло залипание в Locals.


 

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Под остальные форматы получается также делать отдельные модули или все таки где-то лучше объединить с условием?
под А4:
Код - Visual Basic [Выбрать]
  1. Sub PlotByBlocks_А4к() '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 ss As AcadSelectionSet
  23. Set ss = acadDoc.SelectionSets.Item("SS")
  24. If ss Is Nothing Then
  25.     Set ss = acadDoc.SelectionSets.Add("SS")
  26. Else
  27.     ss.Clear ' если используем сущ. SS то очистить его
  28. End If
  29. ss.SelectonScreen
  30. On Error GoTo 0
  31.     i = 0
  32.     For Each objEnt In ss
  33.     If objEnt.ObjectName = "AcDbBlockReference" Then
  34.     Set objBRef = objEnt
  35.         If objBRef.EffectiveName = "А4кшб" Then
  36.         pt1 = objBRef.InsertionPoint
  37.         varAttributes = objBRef.GetAttributes
  38.         l = varAttributes(4).TextString
  39.         ReDim Preserve pt1(0 To 1)
  40.         pt2(0) = pt1(0) + 21000
  41.         pt2(1) = pt1(1) + 29700
  42.         i = i + 1
  43.         PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - А4к", pt1, pt2
  44.         End If
  45.     End If
  46.     Next
  47. End Sub
  48. Sub PolyPlot(ByRef acadDoc, strFileName As String, pt1 As Variant, pt2 As Variant)
  49.     Dim Layout As AcadLayout
  50.     Set Layout = acadDoc.ActiveLayout
  51.     Layout.RefreshPlotDeviceInfo
  52.     Layout.ConfigName = "DWG To PDF.pc3"
  53.     acadDoc.SetVariable "BACKGROUNDPLOT", 0
  54.     Layout.CanonicalMediaName = "ISO_full_bleed_A4_(210.00_x_297.00_MM)"
  55.     Layout.CenterPlot = True
  56.     Layout.PlotRotation = ac0degrees
  57.     Layout.StandardScale = acScaleToFit
  58.     Layout.StyleSheet = "acad.ctb"
  59.     Layout.SetWindowToPlot pt1, pt2
  60.     Layout.PlotType = acWindow
  61.     acadDoc.Regen acAllViewports
  62.     acadDoc.Plot.PlotToFile strFileName
  63. End Sub

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Господа, а если допустим сделать блок динамический
с шагом по "ДЛИНА" = 210,297,420,594,841,1189
и с шагом по "ШИРИНА" = 210,297,420,594,841,1189
Код - Visual Basic [Выбрать]
  1. varBlockProperties = objBRef.GetDynamicBlockProperties
  2. For Index = LBound(varBlockProperties) To UBound(varBlockProperties)
  3. Set prop = varBlockProperties(Index)
  4. If prop = prop.PropertyName = "ДЛИНА" Then
  5. x1 = varBlockProperties(Index).TextString
  6. ElseIf prop = prop.PropertyName = "ШИРИНА" Then
  7. y1 = varBlockProperties(Index).TextString
А вот дальше как-то нужно параметры печати приделать по условиям - пока не понимаю как
Еще бы хорошо научиться ловить параметр блока масштаб и его в умножающий коэффициент для условий координат применять.
А также интересно как программно нестандартный формат задать допустим 1400х594 и убрать ширину полей в созданном листе

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Я бы сделал так.
Создаем динамический блок с атрибутами.
В "Таблице свойств блока" забиваем типоразмеры.

динамические свойства:
   длина
   ширина
атрибуты
   формат -- название формата (скорее для удобства пользования )
   ориентация -- тут указываем ориентацию что бы  назначить Layout.PlotRotation = ac0degrees
   каноническое название формата -- сюда забиваем название формата пример:"ISO_full_bleed_A4_(210.00_x_297.00_MM)"
В "Таблице свойств блока" забиваем типоразмеры.




В коде потом вытаскиваем массив динамических свойств и перебором вытаскиваем инфу по нужным переменным
Аналогично пробегаемся по атрибутам

Таким образом один блок закрывает много форматов

UPD.
Забыл добавить. Точку вставки блока располагаем так что бы это был левый нижний угол (т.е. переменная pt1 в коде), соответственно pt2=pt1+длина(ширина)

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Layout.PlotRotation = ac0degrees - насколько я понял ориентация и для книжного и для альбомного всегда такая. x и y меняются местами в координатах.
там я еще про масштаб дописал в предыдущем сообщении - тоже кажется нужный параметр
и про нестандартные листы создать если такой в списке отсутствует
Сам блок я разобрался как создать динамический примерно - не понимаю как по условиям задать разные форматы в нижней части кода там где Sub PolyPlot

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Левый нижний угол не подойдет вариант будет правый только чтоб штамп не съезжал. Но тогда нужно как-то по другому вычислять рамку печати правый угол имеем и длина ширина параметры знаем.
Значит из точки определения блока из координаты x надо вычесть "Длина", y так и остается с плюсом
Так же у меня остался вопрос что можно дописать чтоб публикация в один файл проходила с отдельным своим именем и отдельно по листу тоже печаталась

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Вот тут примеры по печати, последние по печати нескольких листов (видимо в один файл, не пробовал)
http://www.alex160570.narod.ru/AcadVBA/vba10.htm

по поводу нестандартных листов, у меня не получалось ни до стучаться до сущ. настроек  форматов в .pc3, ни создавать свои форматы в .pc3 программно.
По этому я вижу вариант подготовить (либо самому нашпиговать, либо скачать откуда) файл с настройками печати где будут все форматы.
Эти форматы занести в блок.

 "не понимаю как по условиям задать разные форматы в нижней части кода там где Sub PolyPlot" - копайте тему передача параметров в процедуру. Точки Вы ведь уже передаете

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Nutson,
Ни в одном из публичных AutoCAD API нет возможности создавать нестандартные форматы. Есть сторонняя библиотека для .NET для работы с pc3-файлами.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Nutson, подскажи пожалуйста как можно многострочный текст из ячейки эксель по координатам в кад отправить. (с динамическими столбцами задать ширину столбца промежуток и выравнивание по ширине)

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Вопрос такой возник а что поменять в коде чтоб пдф не открывались после создания

Оффлайн Nutson

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


Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Nutson, подскажи пожалуйста как можно многострочный текст из ячейки эксель по координатам в кад отправить. (с динамическими столбцами задать ширину столбца промежуток и выравнивание по ширине)

Мне кажется админ нас выгонит отсюда, так как вопрос уже не по теме топика.

Для начала надо понять какая цель преследуется.
Если надо просто вставить таблицу из ексель в автокад, то тут без кода можно обойтись:


Если цель заполнять штампы, то я бы советовал смотреть в сторону автокадовского "Поля" (http://cadsupport.ru/2015/09/%D1%84%D0%B8%D1%88%D0%BA%D0%B8-autocad-%D0%BF%D0%BE%D0%BB%D1%8F/)
и что бы это поле ссылалось на пользовательское свойство (http://vbamodel.narod.ru/AutoCAD/idh_SummaryInfo_Object.htm)
Я себе сделал такую таблицу:


Ну если реально просто текст вставлять то идешь сюда:http://www.alex160570.narod.ru/AcadVBA/vba01.htm
глава номер 5 - работа с текстами. Инфу из ячеек брать уже умеешь, текст как создать есть по ссылке

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Мне кажется админ нас выгонит отсюда, так как вопрос уже не по теме топика.
Выгонять не буду, но правило "Один вопрос - одна тема" никто не отменял.
Так что,Timofeev,  для каждого вопроса создавай новую тему.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Nutson,  вот что для нескольких форматов с условиями получилось - не работает - что-то делаю не так
Код - 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 ss As AcadSelectionSet
  24. Set ss = acadDoc.SelectionSets.Item("SS")
  25. If ss Is Nothing Then
  26.     Set ss = acadDoc.SelectionSets.Add("SS")
  27. Else
  28.     ss.Clear ' если используем сущ. SS то очистить его
  29. End If
  30. ss.SelectonScreen
  31. On Error GoTo 0
  32.     i = 0
  33.     For Each objEnt In ss
  34.     If objEnt.ObjectName = "AcDbBlockReference" Then
  35.     Set objBRef = objEnt
  36.     varAttributes = objBRef.GetAttributes
  37.     l = varAttributes(4).TextString
  38.     A4к = 0
  39.     A3а = 0
  40.          If objBRef.EffectiveName = "А4кшб" Or objBRef.EffectiveName = "Титул" Then
  41.         pt1 = objBRef.InsertionPoint
  42.         varAttributes = objBRef.GetAttributes
  43.         l = varAttributes(4).TextString
  44.         ReDim Preserve pt1(0 To 1)
  45.         pt2(0) = pt1(0) + 21000
  46.         pt2(1) = pt1(1) + 29700
  47.         A4к = A4к + 1
  48.         format = "A4к"
  49.         ElseIf objBRef.EffectiveName = "ОД" Or objBRef.EffectiveName = "А3ашб" Then
  50.         pt1 = objBRef.InsertionPoint
  51.         ReDim Preserve pt1(0 To 1)
  52.         pt2(0) = pt1(0) + 42000
  53.         pt2(1) = pt1(1) + 29700
  54.         A3а = A3а + 1
  55.         format = "A3а"
  56.          i = i + 1
  57.         PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  58.         End If
  59.     End If
  60.     Next
  61. End Sub
  62. Sub PolyPlot(ByRef acadDoc, strFileName As String, pt1 As Variant, pt2 As Variant, format As String)
  63.     Dim Layout As AcadLayout
  64.     Set Layout = acadDoc.ActiveLayout
  65.     Layout.RefreshPlotDeviceInfo
  66.     Layout.ConfigName = "DWG To PDF.pc3"
  67.     acadDoc.SetVariable "BACKGROUNDPLOT", 0
  68.     If format = "A4к" Then
  69.     Layout.CanonicalMediaName = "ISO_full_bleed_A4_(210.00_x_297.00_MM)"
  70.     ElseIf format = "A3а" Then
  71.     Layout.CanonicalMediaName = "ISO_full_bleed_A3_(420.00_x_297.00_MM)"
  72.     End If
  73.     Layout.CenterPlot = True
  74.     Layout.PlotRotation = ac0degrees
  75.     Layout.StandardScale = acScaleToFit
  76.     Layout.StyleSheet = "acad.ctb"
  77.     pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False) ' добавил по статье https://adn-cis.org/pechat-granicz-okna-pri-pomoshhi-vba.html
  78.    pt2 = acadDoc.Utility.TranslateCoordinates(pt2, acWorld, acDisplayDCS, False) ' добавил по статье https://adn-cis.org/pechat-granicz-okna-pri-pomoshhi-vba.html
  79.    Layout.SetWindowToPlot pt1, pt2
  80.     Layout.PlotType = acWindow
  81.     acadDoc.Regen acAllViewports
  82.     acadDoc.Plot.PlotToFile strFileName
  83. End Sub

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 43
  • Карма: 6
Что делаете не так:
-выложили код без чертежа на котором его надо тестировать;
-не описали поведение кода. Он ломается? или он просто ничего не произошло?

Делайте отступы в коде. Если открыли блок If то сделайте внутри него отступ - так будет наглядней намного.
Возможно код не отработал от того что строки 56,57 попали в блок условия Elseif.

по строкам 77,78. У Вас изначально в скрипте они были, но почему то при исполнении скрипт на ней спотыкался и я их закомментировал.
Возможно и сейчас скрипт об них спотыкается, так как в 33 строке я отключал игнорирование ошибок

Оффлайн 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
блин не сразу заметил что Вы скинули откорректированный код.
Вот Вы себе вообще не желаете жизнь упрощать? накой черт понадобилось копировать команду печати по всем блокам иф???

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