Обсуждение видеоуроков AutoCAD VBA
« предыдущая тема следующая тема »
Страницы: 1 ... 11 12 [13] 14  Все   Вниз

Автор Тема: Обсуждение видеоуроков AutoCAD VBA  (Прочитано 205970 раз)

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

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #180 : 18-01-2021, 16:40:27 »
Делал по примеру - Ответ #146 в этой теме увидел
Записан

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

  • Administrator
  • *****
  • Сообщений: 13882
  • Карма: 1787
  • Рыцарь ObjectARX
  • Skype: rivilis
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #181 : 18-01-2021, 16:44:54 »
Цитата: Timofeev от 18-01-2021, 16:40:27
Делал по примеру - Ответ #146 в этой теме увидел
Ну я не могу гарантировать, что все примеры в этой теме 100% рабочие.
Записан
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #182 : 18-01-2021, 16:55:49 »
Добавил аргумент format - код один раз отработал и напечатал формат А0 книжный один раз но не из точки блока
Код - 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.         If objBRef.EffectiveName = "А4кшб" Or objBRef.EffectiveName = "ОУ" Or objBRef.EffectiveName = "Титул" Then
  39.         pt1 = objBRef.InsertionPoint
  40.         varAttributes = objBRef.GetAttributes
  41.         l = varAttributes(4).TextString
  42.         ReDim Preserve pt1(0 To 1)
  43.         pt2(0) = pt1(0) + 21000
  44.         pt2(1) = pt1(1) + 29700
  45.         format = "A4к"
  46. ElseIf objBRef.EffectiveName = "ОД" Or objBRef.EffectiveName = "А3ашб" Then
  47.         pt1 = objBRef.InsertionPoint
  48.         ReDim Preserve pt1(0 To 1)
  49.         pt2(0) = pt1(0) + 42000
  50.         pt2(1) = pt1(1) + 29700
  51.         format = "A3а"
  52.         ElseIf objBRef.EffectiveName = "А3кшб" Then
  53.         pt1 = objBRef.InsertionPoint
  54.         ReDim Preserve pt1(0 To 1)
  55.         pt2(0) = pt1(0) + 29700
  56.         pt2(1) = pt1(1) + 42000
  57.         format = "A3к"
  58.         ElseIf objBRef.EffectiveName = "А2ашб" Then
  59.         pt1 = objBRef.InsertionPoint
  60.         ReDim Preserve pt1(0 To 1)
  61.         pt2(0) = pt1(0) + 59400
  62.         pt2(1) = pt1(1) + 42000
  63.         format = "A2а"
  64.         ElseIf objBRef.EffectiveName = "А2кшб" Then
  65.         pt1 = objBRef.InsertionPoint
  66.         ReDim Preserve pt1(0 To 1)
  67.         pt2(0) = pt1(0) + 42000
  68.         pt2(1) = pt1(1) + 59400
  69.         format = "A2к"
  70.         ElseIf objBRef.EffectiveName = "А1ашб" Then
  71.         pt1 = objBRef.InsertionPoint
  72.         ReDim Preserve pt1(0 To 1)
  73.         pt2(0) = pt1(0) + 84100
  74.         pt2(1) = pt1(1) + 59400
  75.         format = "A1а"
  76.         ElseIf objBRef.EffectiveName = "А1кшб" Then
  77.         pt1 = objBRef.InsertionPoint
  78.         ReDim Preserve pt1(0 To 1)
  79.         pt2(0) = pt1(0) + 59400
  80.         pt2(1) = pt1(1) + 84100
  81.         format = "A1к"
  82.         ElseIf objBRef.EffectiveName = "А0ашб" Then
  83.         pt1 = objBRef.InsertionPoint
  84.         ReDim Preserve pt1(0 To 1)
  85.         pt2(0) = pt1(0) + 11890
  86.         pt2(1) = pt1(1) + 84100
  87.         format = "A0а"
  88.         ElseIf objBRef.EffectiveName = "А0кшб" Then
  89.         pt1 = objBRef.InsertionPoint
  90.         ReDim Preserve pt1(0 To 1)
  91.         pt2(0) = pt1(0) + 84100
  92.         pt2(1) = pt1(1) + 11890
  93.         format = "A0к"
  94.         i = i + 1
  95.         PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  96.         End If
  97.     End If
  98.     Next
  99. End Sub
  100. Sub PolyPlot(ByRef acadDoc, strFileName As String, pt1 As Variant, pt2 As Variant, format As String)
  101.     Dim Layout As AcadLayout
  102.     Set Layout = acadDoc.ActiveLayout
  103.     Layout.RefreshPlotDeviceInfo
  104.     Layout.ConfigName = "DWG To PDF.pc3"
  105.     acadDoc.SetVariable "BACKGROUNDPLOT", 0
  106.     If format = "A4к" Then
  107.     Layout.CanonicalMediaName = "ISO_full_bleed_A4_(210.00_x_297.00_MM)"
  108.     ElseIf format = "A3а" Then
  109.     Layout.CanonicalMediaName = "ISO_full_bleed_A3_(420.00_x_297.00_MM)"
  110.     ElseIf format = "A3к" Then
  111.     Layout.CanonicalMediaName = "ISO_full_bleed_A3_(297.00_x_420.00_MM)"
  112.     ElseIf format = "A2а" Then
  113.     Layout.CanonicalMediaName = "ISO_full_bleed_A2_(594.00_x_420.00_MM)"
  114.     ElseIf format = "A2к" Then
  115.     Layout.CanonicalMediaName = "ISO_full_bleed_A2_(420.00_x_594.00_MM)"
  116.     ElseIf format = "A1а" Then
  117.     Layout.CanonicalMediaName = "ISO_full_bleed_A1_(841.00_x_594.00_MM)"
  118.     ElseIf format = "A1к" Then
  119.     Layout.CanonicalMediaName = "ISO_full_bleed_A1_(594.00_x_841.00_MM)"
  120.     ElseIf format = "A0а" Then
  121.     Layout.CanonicalMediaName = "ISO_full_bleed_A0_(1189.00_x_841.00_MM)"
  122.     ElseIf format = "A0к" Then
  123.     Layout.CanonicalMediaName = "ISO_full_bleed_A0_(841.00_x_1189.00_MM)"
  124.     End If
  125.     Layout.CenterPlot = True
  126.     Layout.PlotRotation = ac0degrees
  127.     Layout.StandardScale = acScaleToFit
  128.     Layout.StyleSheet = "acad.ctb"
  129.     Layout.SetWindowToPlot pt1, pt2
  130.     Layout.PlotType = acWindow
  131.     acadDoc.Regen acAllViewports
  132.     acadDoc.Plot.PlotToFile strFileName
  133. End Sub
  134.  
Записан

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

  • Administrator
  • *****
  • Сообщений: 13882
  • Карма: 1787
  • Рыцарь ObjectARX
  • Skype: rivilis
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #183 : 18-01-2021, 17:00:55 »
Как минимум координаты следует преобразовать в ДСК (DCS), как сказано в этой статье: https://adn-cis.org/pechat-granicz-okna-pri-pomoshhi-vba.html
Записан
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #184 : 18-01-2021, 17:16:54 »
Обнулил форматы как в примере. Добавил согласно статье перевод координат (может не там, может не везде). Печатается один лист и не то что надо)
Код - 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.     A3к = 0
  41.     A2а = 0
  42.     A2к = 0
  43.     A1а = 0
  44.     A1к = 0
  45.     A0а = 0
  46.     A0к = 0
  47.         If objBRef.EffectiveName = "А4кшб" Or objBRef.EffectiveName = "ОУ" Or objBRef.EffectiveName = "Титул" Then
  48.         pt1 = objBRef.InsertionPoint
  49.         pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False) ' добавил по статье https://adn-cis.org/pechat-granicz-okna-pri-pomoshhi-vba.html
  50.        varAttributes = objBRef.GetAttributes
  51.         l = varAttributes(4).TextString
  52.         ReDim Preserve pt1(0 To 1)
  53.         pt2(0) = pt1(0) + 21000
  54.         pt2(1) = pt1(1) + 29700
  55.         A4к = A4к + 1
  56.         format = "A4к"
  57.         ElseIf objBRef.EffectiveName = "ОД" Or objBRef.EffectiveName = "А3ашб" Then
  58.         pt1 = objBRef.InsertionPoint
  59.         ReDim Preserve pt1(0 To 1)
  60.         pt2(0) = pt1(0) + 42000
  61.         pt2(1) = pt1(1) + 29700
  62.         A3а = A3а + 1
  63.         format = "A3а"
  64.         ElseIf objBRef.EffectiveName = "А3кшб" Then
  65.         pt1 = objBRef.InsertionPoint
  66.         ReDim Preserve pt1(0 To 1)
  67.         pt2(0) = pt1(0) + 29700
  68.         pt2(1) = pt1(1) + 42000
  69.         A3к = A3к + 1
  70.         format = "A3к"
  71.         ElseIf objBRef.EffectiveName = "А2ашб" Then
  72.         pt1 = objBRef.InsertionPoint
  73.         ReDim Preserve pt1(0 To 1)
  74.         pt2(0) = pt1(0) + 59400
  75.         pt2(1) = pt1(1) + 42000
  76.         A2а = A2а + 1
  77.         format = "A2а"
  78.         ElseIf objBRef.EffectiveName = "А2кшб" Then
  79.         pt1 = objBRef.InsertionPoint
  80.         ReDim Preserve pt1(0 To 1)
  81.         pt2(0) = pt1(0) + 42000
  82.         pt2(1) = pt1(1) + 59400
  83.         A2к = A2к + 1
  84.         format = "A2к"
  85.         ElseIf objBRef.EffectiveName = "А1ашб" Then
  86.         pt1 = objBRef.InsertionPoint
  87.         ReDim Preserve pt1(0 To 1)
  88.         pt2(0) = pt1(0) + 84100
  89.         pt2(1) = pt1(1) + 59400
  90.         A1а = A1а + 1
  91.         format = "A1а"
  92.         ElseIf objBRef.EffectiveName = "А1кшб" Then
  93.         pt1 = objBRef.InsertionPoint
  94.         ReDim Preserve pt1(0 To 1)
  95.         pt2(0) = pt1(0) + 59400
  96.         pt2(1) = pt1(1) + 84100
  97.         A1к = A1к + 1
  98.         format = "A1к"
  99.         ElseIf objBRef.EffectiveName = "А0ашб" Then
  100.         pt1 = objBRef.InsertionPoint
  101.         ReDim Preserve pt1(0 To 1)
  102.         pt2(0) = pt1(0) + 11890
  103.         pt2(1) = pt1(1) + 84100
  104.         A0а = A0а + 1
  105.         format = "A0а"
  106.         ElseIf objBRef.EffectiveName = "А0кшб" Then
  107.         pt1 = objBRef.InsertionPoint
  108.         ReDim Preserve pt1(0 To 1)
  109.         pt2(0) = pt1(0) + 84100
  110.         pt2(1) = pt1(1) + 11890
  111.         A0к = A0к + 1
  112.         format = "A0к"
  113.         i = i + 1
  114.         PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  115.         End If
  116.     End If
  117.     Next
  118. End Sub
  119. Sub PolyPlot(ByRef acadDoc, strFileName As String, pt1 As Variant, pt2 As Variant, format As String)
  120.     Dim Layout As AcadLayout
  121.     Set Layout = acadDoc.ActiveLayout
  122.     Layout.RefreshPlotDeviceInfo
  123.     Layout.ConfigName = "DWG To PDF.pc3"
  124.     acadDoc.SetVariable "BACKGROUNDPLOT", 0
  125.     If format = "A4к" Then
  126.     Layout.CanonicalMediaName = "ISO_full_bleed_A4_(210.00_x_297.00_MM)"
  127.     ElseIf format = "A3а" Then
  128.     Layout.CanonicalMediaName = "ISO_full_bleed_A3_(420.00_x_297.00_MM)"
  129.     ElseIf format = "A3к" Then
  130.     Layout.CanonicalMediaName = "ISO_full_bleed_A3_(297.00_x_420.00_MM)"
  131.     ElseIf format = "A2а" Then
  132.     Layout.CanonicalMediaName = "ISO_full_bleed_A2_(594.00_x_420.00_MM)"
  133.     ElseIf format = "A2к" Then
  134.     Layout.CanonicalMediaName = "ISO_full_bleed_A2_(420.00_x_594.00_MM)"
  135.     ElseIf format = "A1а" Then
  136.     Layout.CanonicalMediaName = "ISO_full_bleed_A1_(841.00_x_594.00_MM)"
  137.     ElseIf format = "A1к" Then
  138.     Layout.CanonicalMediaName = "ISO_full_bleed_A1_(594.00_x_841.00_MM)"
  139.     ElseIf format = "A0а" Then
  140.     Layout.CanonicalMediaName = "ISO_full_bleed_A0_(1189.00_x_841.00_MM)"
  141.     ElseIf format = "A0к" Then
  142.     Layout.CanonicalMediaName = "ISO_full_bleed_A0_(841.00_x_1189.00_MM)"
  143.     End If
  144.     Layout.CenterPlot = True
  145.     Layout.PlotRotation = ac0degrees
  146.     Layout.StandardScale = acScaleToFit
  147.     Layout.StyleSheet = "acad.ctb"
  148.     Layout.SetWindowToPlot pt1, pt2
  149.     Layout.PlotType = acWindow
  150.     acadDoc.Regen acAllViewports
  151.     acadDoc.Plot.PlotToFile strFileName
  152. End Sub
Записан

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

  • Administrator
  • *****
  • Сообщений: 13882
  • Карма: 1787
  • Рыцарь ObjectARX
  • Skype: rivilis
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #185 : 18-01-2021, 17:22:19 »
pt2 тоже нужно преобразовывать. Лучше всего и pt1 и pt2 преобразовывать в методе PolyPlot перед Layout.SetWindowToPlot pt1, pt2
Всё остальное не проверял - запускай в режиме отладки и смотри что происходит.
Записан
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #186 : 18-01-2021, 17:29:30 »
если переношу сюда
Код - Visual Basic [Выбрать]
  1.  pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False) ' добавил по статье https://adn-cis.org/pechat-granicz-okna-pri-pomoshhi-vba.html
  2.    pt2 = acadDoc.Utility.TranslateCoordinates(pt2, acWorld, acDisplayDCS, False) ' добавил по статье https://adn-cis.org/pechat-granicz-okna-pri-pomoshhi-vba.html
  3. ReDim Preserve pt1(0 To 1)
  4. ReDim Preserve pt2(0 To 1)
  5.     Layout.SetWindowToPlot pt1, pt2
То Ошибка преобразования точки из SafeArray в точку двойного массива '-2145320947 (8021000d)
Записан

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #187 : 18-01-2021, 18:08:41 »
Последнее действие убрал - в нем сразу ошибка без него хоть один лист печатало!
Пройдясь по F8 наверное не хватает в коде скорее всего последующий лист затирает предыдущего данные и поэтому печатается один лист
Вот это я пропустил:
Dim arr() As AcadEntity
Dim arr2() As AcadEntity
Записан

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #188 : 18-01-2021, 18:57:01 »
Добавил в код - все равно печатает только один лист формат 841х1189 книжный и все - чего то не хватает ....
Код - 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.         If arr(i).EffectiveName = "А4кшб" Then
  49.         varAttributes = arr(i).GetAttributes
  50.         l = varAttributes(4).TextString
  51.         pt1 = arr(i).InsertionPoint
  52.         pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  53.         ReDim Preserve pt1(0 To 1)
  54.         pt2(0) = pt1(0) + 21000
  55.         pt2(1) = pt1(1) + 29700
  56.         A4к = A4к + 1
  57.         format = "A4к"
  58.         ElseIf arr(i).EffectiveName = "ОД" Or arr(i).EffectiveName = "А3ашб" Then
  59.         varAttributes = arr(i).GetAttributes
  60.         l = varAttributes(4).TextString
  61.         pt1 = arr(i).InsertionPoint
  62.         pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  63.         ReDim Preserve pt1(0 To 1)
  64.         pt2(0) = pt1(0) + 42000
  65.         pt2(1) = pt1(1) + 29700
  66.         A3а = A3а + 1
  67.         format = "A3а"
  68.         ElseIf arr(i).EffectiveName = "А3кшб" Then
  69.         varAttributes = arr(i).GetAttributes
  70.         l = varAttributes(4).TextString
  71.         pt1 = arr(i).InsertionPoint
  72.         pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  73.         ReDim Preserve pt1(0 To 1)
  74.         pt2(0) = pt1(0) + 29700
  75.         pt2(1) = pt1(1) + 42000
  76.         A3к = A3к + 1
  77.         format = "A3к"
  78.         ElseIf arr(i).EffectiveName = "А2ашб" Then
  79.         varAttributes = arr(i).GetAttributes
  80.         l = varAttributes(4).TextString
  81.         pt1 = arr(i).InsertionPoint
  82.         pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  83.         ReDim Preserve pt1(0 To 1)
  84.         pt2(0) = pt1(0) + 59400
  85.         pt2(1) = pt1(1) + 42000
  86.         A2а = A2а + 1
  87.         format = "A2а"
  88.         ElseIf arr(i).EffectiveName = "А2кшб" Then
  89.         varAttributes = arr(i).GetAttributes
  90.         l = varAttributes(4).TextString
  91.         pt1 = arr(i).InsertionPoint
  92.         pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  93.         ReDim Preserve pt1(0 To 1)
  94.         pt2(0) = pt1(0) + 42000
  95.         pt2(1) = pt1(1) + 59400
  96.         A2к = A2к + 1
  97.         format = "A2к"
  98.         ElseIf arr(i).EffectiveName = "А1ашб" Then
  99.         varAttributes = arr(i).GetAttributes
  100.         l = varAttributes(4).TextString
  101.         pt1 = arr(i).InsertionPoint
  102.         pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  103.         ReDim Preserve pt1(0 To 1)
  104.         pt2(0) = pt1(0) + 84100
  105.         pt2(1) = pt1(1) + 59400
  106.         A1а = A1а + 1
  107.         format = "A1а"
  108.         ElseIf arr(i).EffectiveName = "А1кшб" Then
  109.         varAttributes = arr(i).GetAttributes
  110.         l = varAttributes(4).TextString
  111.         pt1 = arr(i).InsertionPoint
  112.         pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  113.         ReDim Preserve pt1(0 To 1)
  114.         pt2(0) = pt1(0) + 59400
  115.         pt2(1) = pt1(1) + 84100
  116.         A1к = A1к + 1
  117.         format = "A1к"
  118.         ElseIf arr(i).EffectiveName = "А0ашб" Then
  119.         varAttributes = arr(i).GetAttributes
  120.         l = varAttributes(4).TextString
  121.         pt1 = arr(i).InsertionPoint
  122.         pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  123.         ReDim Preserve pt1(0 To 1)
  124.         pt2(0) = pt1(0) + 11890
  125.         pt2(1) = pt1(1) + 84100
  126.         A0а = A0а + 1
  127.         format = "A0а"
  128.         ElseIf arr(i).EffectiveName = "А0кшб" Then
  129.         varAttributes = arr(i).GetAttributes
  130.         l = varAttributes(4).TextString
  131.         pt1 = arr(i).InsertionPoint
  132.         pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  133.         ReDim Preserve pt1(0 To 1)
  134.         pt2(0) = pt1(0) + 84100
  135.         pt2(1) = pt1(1) + 11890
  136.         A0к = A0к + 1
  137.         format = "A0к"
  138.         PolyPlot acadDoc, ActiveWorkbook.Path + "\" + CStr(n) + " - ИЧ Лист " + CStr(l) + " - ", pt1, pt2, format
  139.         End If
  140.         Next
  141. End Sub
  142. Sub PolyPlot(ByRef acadDoc, strFileName As String, pt1 As Variant, pt2 As Variant, format As String)
  143.     Dim Layout As AcadLayout
  144.     Set Layout = acadDoc.ActiveLayout
  145.     Layout.RefreshPlotDeviceInfo
  146.     Layout.ConfigName = "DWG To PDF.pc3"
  147.     acadDoc.SetVariable "BACKGROUNDPLOT", 0
  148.     If format = "A4к" Then
  149.     Layout.CanonicalMediaName = "ISO_full_bleed_A4_(210.00_x_297.00_MM)"
  150.     ElseIf format = "A3а" Then
  151.     Layout.CanonicalMediaName = "ISO_full_bleed_A3_(420.00_x_297.00_MM)"
  152.     ElseIf format = "A3к" Then
  153.     Layout.CanonicalMediaName = "ISO_full_bleed_A3_(297.00_x_420.00_MM)"
  154.     ElseIf format = "A2а" Then
  155.     Layout.CanonicalMediaName = "ISO_full_bleed_A2_(594.00_x_420.00_MM)"
  156.     ElseIf format = "A2к" Then
  157.     Layout.CanonicalMediaName = "ISO_full_bleed_A2_(420.00_x_594.00_MM)"
  158.     ElseIf format = "A1а" Then
  159.     Layout.CanonicalMediaName = "ISO_full_bleed_A1_(841.00_x_594.00_MM)"
  160.     ElseIf format = "A1к" Then
  161.     Layout.CanonicalMediaName = "ISO_full_bleed_A1_(594.00_x_841.00_MM)"
  162.     ElseIf format = "A0а" Then
  163.     Layout.CanonicalMediaName = "ISO_full_bleed_A0_(1189.00_x_841.00_MM)"
  164.     ElseIf format = "A0к" Then
  165.     Layout.CanonicalMediaName = "ISO_full_bleed_A0_(841.00_x_1189.00_MM)"
  166.     End If
  167.     Layout.CenterPlot = True
  168.     Layout.PlotRotation = ac0degrees
  169.     Layout.StandardScale = acScaleToFit
  170.     Layout.StyleSheet = "acad.ctb"
  171.     Layout.SetWindowToPlot pt1, pt2
  172.     Layout.PlotType = acWindow
  173.     acadDoc.Regen acAllViewports
  174.     acadDoc.Plot.PlotToFile strFileName
  175. End Sub
Записан

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #189 : 18-01-2021, 19:02:25 »
При чем печатается последний лист А0кшб, атрибут берет правильно, но печатает совсем не так.
Перебор значит идет но в никуда, последующее значение затирает предыдущее и перевод координат не работает видимо что-то я не дочитал
Записан

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 44
  • Карма: 6
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #190 : 19-01-2021, 06:37:11 »
Уф, какой раздутый код :o

обратите внимание что в каждом блоке elseif у Вас повторяются строки:
Код - Visual Basic [Выбрать]
  1.         varAttributes = arr(i).GetAttributes
  2.         l = varAttributes(4).TextString
  3.         pt1 = arr(i).InsertionPoint
  4.         pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  5.         ReDim Preserve pt1(0 To 1)
  6.  
То есть код их должен выполнить обязательно, так и вынесите его до блока if. Чем больше код тем труднее его понимать и искать в нем промахи.
Почему Вы не стали реализовывать идею с единым динамическим блоком?
Я подготовил Вам пример как можно сделать намного проще:
Записан

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #191 : 19-01-2021, 10:16:00 »
Спасибо большое за пример ругается на строку 57 ReDim Preserve pt1(0 To 1) - Invalid Redim
Код - Visual Basic [Выбрать]
  1. Sub PlotByBlocks()
  2. 'Tools -> References-> ïîäêëþ÷èòü áèáëèîòåêó AutoCAD 20XX Type Library
  3. On Error Resume Next
  4.  
  5. Dim acadApp As AcadApplication
  6. Dim acadDoc As AcadDocument
  7. 'Ïîëó÷àåì ññûëêó íà ïðèëîæåíèå àâòîêàäà
  8. Set acadApp = GetObject(, "AutoCad.Application")
  9. Set acadDoc = acadApp.ActiveDocument
  10.  
  11. If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
  12.    acadDoc.ActiveSpace = 1     '1 = acModelSpace in early binding
  13. End If
  14.  
  15.     Dim objEnt As AcadObject
  16.     Dim objBRef As AcadBlockReference
  17.     Dim pt2(0 To 1) As Double
  18.     Dim ss As AcadSelectionSet
  19.  
  20. acadDoc.SetVariable "BACKGROUNDPLOT", 0
  21.  
  22. Set ss = acadDoc.SelectionSets.Item("SS")
  23. If ss Is Nothing Then
  24.     Set ss = acadDoc.SelectionSets.Add("SS")
  25. Else
  26.     ss.Clear
  27. End If
  28. On Error GoTo 0
  29.  
  30. ss.SelectonScreen
  31. If ss.Count > 0 Then
  32.         For Each objEnt In ss
  33.             If objEnt.ObjectName = "AcDbBlockReference" Then
  34.                 Set objBRef = objEnt
  35.                 If objBRef.EffectiveName = "ðàìêà" Then
  36.                     pt1 = objBRef.InsertionPoint
  37.                     pt1 = acadDoc.Utility.TranslateCoordinates(pt1, acWorld, acDisplayDCS, False)
  38.                    
  39.                     varAttributes = objBRef.GetAttributes '
  40.                    For Each att In varAttributes
  41.                         Select Case att.TagString
  42.                             Case "ÊÀÍÎÍ_ÔÎÐÌÀÒ"
  43.                                 CanonicalMediaName = att.TextString
  44.                         End Select
  45.                     Next
  46.                    
  47.                     dynProp = objBRef.GetDynamicBlockProperties
  48.                     For Each dyn In dynProp
  49.                         Select Case dyn.PropertyName
  50.                             Case "Äëèíà"
  51.                                 blcLength = dyn.Value
  52.                             Case "Øèðèíà"
  53.                                 blcWeigth = dyn.Value
  54.                         End Select
  55.                     Next
  56.                    
  57.                     ReDim Preserve pt1(0 To 1)
  58.                     pt2(0) = pt1(0) + blcLength
  59.                     pt2(1) = pt1(1) + blcWeigth
  60.                     i = i + 1
  61.                     Call PolyPlot(acadDoc, CanonicalMediaName, ActiveWorkbook.Path + "\À1 Ëèñò" + CStr(i), pt1, pt2)
  62.                 End If
  63.             End If
  64.         Next
  65.     End If
  66. End Sub
  67. Sub PolyPlot(ByRef acadDoc, CanonicalMediaName, strFileName As String, pt1 As Variant, pt2 As Variant)
  68.     Dim Layout As AcadLayout
  69.     Set Layout = acadDoc.ActiveLayout
  70.    
  71.     Layout.RefreshPlotDeviceInfo
  72.     Layout.ConfigName = "DWG To PDF.pc3"
  73.     Layout.CanonicalMediaName = CanonicalMediaName
  74.     Layout.CenterPlot = True
  75.     Layout.StandardScale = acScaleToFit
  76.     Layout.StyleSheet = "acad.ctb"
  77.     Layout.SetWindowToPlot pt1, pt2
  78.     Layout.PlotType = acWindow
  79.    
  80.     acadDoc.Regen acAllViewports
  81.     acadDoc.Plot.PlotToFile strFileName
  82. End Sub
Записан

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 44
  • Карма: 6
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #192 : 19-01-2021, 10:19:44 »
я дал маху и удалил объявление массива pt1, с копируйте обратно
Записан

Оффлайн Timofeev

  • ADN OPEN
  • Сообщений: 47
  • Карма: 0
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #193 : 19-01-2021, 10:38:59 »
вернул объявление - код отработал как нужно
Пример просто отличный !!!!
Еще переменную надо добавить масштаб как-то и умножать на него координаты pt
Записан

Оффлайн Nutson

  • ADN OPEN
  • Сообщений: 44
  • Карма: 6
Re: Обсуждение видеоуроков AutoCAD VBA
« Ответ #194 : 19-01-2021, 10:42:43 »
не нужно ни каких переменных, попробуйте увеличьте в 1000 раз блок и прогоните скрипт.
А потом можно дебагом посмотреть почему все равно получается
Записан
Страницы: 1 ... 11 12 [13] 14  Все   Вверх
« предыдущая тема следующая тема »