Засыпает VBA-код при работе

Автор Тема: Засыпает VBA-код при работе  (Прочитано 2256 раз)

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

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

  • ADN OPEN
  • Сообщений: 12
  • Карма: 0
Доброго времени суток.

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

Как это побороть или хотябы понять: Как и почему?

Заранее спасибо.

Оффлайн mikazakov

  • ADN
  • *
  • Сообщений: 654
  • Карма: 165
  • Skype: mikazakov@mail.ru
Re: Засыпает VBA-код при работе
« Ответ #1 : 20-08-2021, 12:27:29 »
Судя по описанию, окно инвентора теряет фокус.
А на какой конкретно функции это происходит?

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

  • ADN OPEN
  • Сообщений: 12
  • Карма: 0
Re: Засыпает VBA-код при работе
« Ответ #2 : 20-08-2021, 12:34:51 »
Конкретно операцию я не могу определить. В это время открыт чертеж детали. Операции я описал выше. Попробовали делать тоже самое не открывая чертежа на экране, тоже самое... и в то же самое время...

Оффлайн filat

  • ADN Club
  • ***
  • Сообщений: 237
  • Карма: 2
Re: Засыпает VBA-код при работе
« Ответ #3 : 20-08-2021, 13:00:16 »
А если попробовать, в начале макроса, отключить обновление экрана, а в конце включить?
Так, без кода сложно что-то комментировать...
Судя по всему код - длинный. Попробуйте его разбить на отдельные сабы ( один заканчивается - запускает следующий, ...), а в каждом сабе прописать Debug.Print - маркер-идетнификатор - хотя бы поймете на каком этапе происходит сбой...

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

  • ADN OPEN
  • Сообщений: 12
  • Карма: 0
Re: Засыпает VBA-код при работе
« Ответ #4 : 20-08-2021, 13:18:13 »
Вот код фукции которую он в это время выполняет:

Код - Visual Basic [Выбрать]
  1. Private Sub AddDimensionsPurlins(zielOrdner As String, dateiPrefix As String, purlinFileList As Collection, purlinIdwFileList As Collection, isZeta As Boolean, isZetaII As Boolean, isLC As Boolean, isLT As Boolean, purlinName As String, isGen2WithSpringPlate As Boolean, moduleClampAdapter As Long, sparrensystem As Long, mitPfettenklaue As Boolean)
  2.  
  3.     Dim idwFileOrg As String
  4.     Dim idwFile As String
  5.     Dim idwFilePrev As String
  6.        
  7.     Dim purlinFileNameStartIdx As Long
  8.     Dim purlinFileNameShort As String
  9.    
  10.     Dim doc As DrawingDocument
  11.     Dim s As Sheet
  12.        
  13.     If isZetaII Or isLC Or isLT Then
  14.         idwFileOrg = zielOrdner + "\" + dateiPrefix + "_PFETTEN - LC-LT-Z II.idw"
  15.     Else
  16.         idwFileOrg = zielOrdner + "\" + dateiPrefix + "_PFETTE_Zeta.idw"
  17.     End If
  18.    
  19.     ThisApplication.SilentOperation = True
  20.        
  21.     For i = 1 To purlinFileList.count
  22.         purlinFileNameStartIdx = InStr(1, purlinFileList(i), "_PFETTE")
  23.         purlinFileNameShort = GetFileNameWithoutExt(Mid(purlinFileList(i), purlinFileNameStartIdx))
  24.                
  25.         idwFile = zielOrdner + "\" + dateiPrefix + purlinFileNameShort + ".idw"
  26.  
  27.         purlinIdwFileList.Add idwFile
  28.  
  29.         If i = 1 Then
  30.             Name idwFileOrg As idwFile
  31.         Else
  32.             FileCopy idwFilePrev, idwFile
  33.         End If
  34.        
  35.         idwFilePrev = idwFile
  36.     Next i
  37.    
  38.     For i = 1 To purlinFileList.count
  39.         purlinFileNameStartIdx = InStr(1, purlinFileList(i), "_PFETTE")
  40.         purlinFileNameShort = GetFileNameWithoutExt(Mid(purlinFileList(i), purlinFileNameStartIdx))
  41.        
  42.         idwFile = zielOrdner + "\" + dateiPrefix + purlinFileNameShort + ".idw"
  43.                
  44.         Set doc = ThisApplication.Documents.Open(idwFile, False)
  45.         Set s = doc.Sheets(1)
  46.        
  47.         UpdateReferenceDoc doc, "_PFETTE", purlinFileList(i)
  48.        
  49.         doc.Update
  50.        
  51.         Dim cidx1 As Long
  52.         Dim cidx2 As Long
  53.         Dim cidx3 As Long
  54.         Dim sPurlinLen As String
  55.        
  56.         cidx1 = LastIndexOf(purlinFileList(i), "_") + 1
  57.         cidx2 = LastIndexOf(purlinFileList(i), ".")
  58.         cidx3 = LastIndexOf(purlinFileList(i), "(")
  59.        
  60.         If cidx2 > cidx3 And cidx3 > 0 Then
  61.             sPurlinLen = Mid(purlinFileList(i), cidx1, cidx3 - cidx1)
  62.         Else
  63.             sPurlinLen = Mid(purlinFileList(i), cidx1, cidx2 - cidx1)
  64.         End If
  65.        
  66.         AddDimensionsPurlin s, purlinFileList(i), CLng(sPurlinLen), isGen2WithSpringPlate, moduleClampAdapter, sparrensystem, mitPfettenklaue
  67.          
  68.         doc.Save
  69.         doc.Close
  70.     Next i
  71.  
  72.     If isZetaII Or isLC Or isLT Then
  73.         Kill zielOrdner + "\" + dateiPrefix + "_PFETTE_Zeta.idw"
  74.     Else
  75.         Kill zielOrdner + "\" + dateiPrefix + "_PFETTEN - LC-LT-Z II.idw"
  76.     End If
  77.  
  78.  
  79.    
  80.     ThisApplication.SilentOperation = False
  81.    
  82. End Sub

и подфукция для простановки размеров:

Код - Visual Basic [Выбрать]
  1. Private Sub AddDimensionsPurlin(s As Sheet, purlinFile As String, pf_laenge As Long, isGen2WithSpringPlate As Boolean, moduleClampAdapter As Long, sparrensystem As Long, mitPfettenklaue As Boolean)
  2.                      
  3.     s.Activate
  4.        
  5.     Dim va As DrawingView
  6.     Dim vb As DrawingView
  7.     Dim vy As DrawingView
  8.    
  9.     Set vb = GetDrawingViewS(s, "B")
  10.     Set va = GetDrawingViewS(s, "A")
  11.     Set vy = GetDrawingViewS(s, "Y")
  12.          
  13.     If moduleClampAdapter > 0 Or (sparrensystem And mitPfettenklaue) Then
  14.         vy.Delete
  15.     End If
  16.    
  17.     Dim refDocA As PartDocument
  18.     Set refDocA = GetViewDocS(s, "A")
  19.    
  20.     Dim refDocB As PartDocument
  21.     Set refDocB = GetViewDocS(s, "B")
  22.                                
  23.     Dim wpIdx As Integer
  24.     Dim yPos As Double
  25.        
  26.     Dim wpPointsA As WorkPoints
  27.     Set wpPointsA = refDocA.ComponentDefinition.WorkPoints
  28.        
  29.     Dim giPointsA() As GeometryIntent
  30.     Dim wpPointColA As New Collection
  31.    
  32.     Dim dlIdx As Long
  33.     Dim ods As OrdinateDimensionSet
  34.     Dim od As OrdinateDimension
  35.    
  36.     Dim ld As LinearGeneralDimension
  37.    
  38.     For i = 1 To wpPointsA.count
  39.         If wpPointsA(i).Point.Y >= 0 Then
  40.             va.SetIncludeStatus wpPointsA(i), True
  41.             wpPointColA.Add wpPointsA(i)
  42.         End If
  43.     Next i
  44.    
  45.     InitSheetSettingsS s, 2, 4, 1, 1, 1
  46.     CenterViewOnSheetHS s, "1"
  47.                                
  48.     AdjustViewScaleS s, "1", GetSheetContentWidthPaddingS(s), GetSheetContentHeightPaddingS(s), 5
  49.    
  50.     vb.Label.Position = ThisApplication.TransientGeometry.CreatePoint2d(vb.Label.Position.X, vb.Position.Y + 2.8)
  51.     va.Label.Position = ThisApplication.TransientGeometry.CreatePoint2d(va.Label.Position.X, va.Position.Y + 2.8)
  52.    
  53.     giPointsA = GetSortetGiList(s, wpPointColA)
  54.    
  55.     yPos = -0.3
  56.    
  57.    
  58.     For wpIdx = 1 To UBound(giPointsA)
  59.         If wpIdx > 1 Then
  60.             Set ld = AddDimensionLineGi(s, giPointsA(wpIdx - 1), giPointsA(wpIdx), 1.2, False)
  61.                
  62.             If wpIdx = UBound(giPointsA) Then
  63.                 ld.Tolerance.SetToSymmetric 3 / 10
  64.             Else
  65.                 ld.Tolerance.SetToSymmetric 1 / 10
  66.             End If
  67.         End If
  68.     Next
  69.    
  70.     Set ods = AddOrdinateDimensionLineSetGi(s, giPointsA, -0.3, False)
  71.        
  72.    
  73.     For dlIdx = 1 To ods.Members.count
  74.         Set od = ods.Members(dlIdx)
  75.        
  76.         If dlIdx = ods.Members.count Then
  77.             od.Tolerance.SetToSymmetric Ceiling(pf_laenge / 1000) / 2 / 10
  78.         ElseIf dlIdx > 1 And dlIdx < ods.Members.count Then
  79.             od.Tolerance.SetToReference
  80.         End If
  81.     Next dlIdx
  82.     '--
  83.            
  84.     Dim wpPointsB As WorkPoints
  85.     Set wpPointsB = refDocB.ComponentDefinition.WorkPoints
  86.        
  87.     Dim giPointsB() As GeometryIntent
  88.     Dim wpPointColB As New Collection
  89.    
  90.     For i = 1 To wpPointsB.count
  91.         If wpPointsB(i).Point.Y <= 0 Then
  92.             vb.SetIncludeStatus wpPointsB(i), True
  93.             wpPointColB.Add wpPointsB(i)
  94.         End If
  95.     Next i
  96.        
  97.     giPointsB = GetSortetGiList(s, wpPointColB)
  98.            
  99.     yPos = -0.3
  100.    
  101.    
  102.     For wpIdx = 1 To UBound(giPointsB)
  103.         If wpIdx > 1 Then
  104.             Set ld = AddDimensionLineGi(s, giPointsB(wpIdx - 1), giPointsB(wpIdx), 1.3, False)
  105.            
  106.             If wpIdx = UBound(giPointsB) Then
  107.                 ld.Tolerance.SetToSymmetric 3 / 10
  108.             Else
  109.                 ld.Tolerance.SetToSymmetric 1 / 10
  110.             End If
  111.         End If
  112.     Next
  113.        
  114.     Set ods = AddOrdinateDimensionLineSetGi(s, giPointsB, -0.3, False)
  115.    
  116.     For dlIdx = 1 To ods.Members.count
  117.         Set od = ods.Members(dlIdx)
  118.        
  119.         If dlIdx = ods.Members.count Then
  120.             od.Tolerance.SetToSymmetric Ceiling(pf_laenge / 1000) / 2 / 10
  121.         ElseIf dlIdx > 1 And dlIdx < ods.Members.count Then
  122.             od.Tolerance.SetToReference
  123.         End If
  124.     Next dlIdx
  125.     '--
  126.                        
  127. End Sub





Оффлайн mikazakov

  • ADN
  • *
  • Сообщений: 654
  • Карма: 165
  • Skype: mikazakov@mail.ru
Re: Засыпает VBA-код при работе
« Ответ #5 : 21-08-2021, 20:07:55 »
Вот код фукции которую он в это время выполняет:
Ну такой не причесанный код я не могу у себя потестить.
Попробуйте использовать функцию для отладки.

Debug.Print

Вставьте эту функцию в нескольких местах по телу программы и посмотрите в соответствующем окне , что будет выводится



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

  • ADN OPEN
  • Сообщений: 12
  • Карма: 0
Re: Засыпает VBA-код при работе
« Ответ #6 : 25-08-2021, 15:10:53 »
Доброго времени. Сегодня определил место на котором останавливается... Но решения так и не удалось найти.
Останавливается на этой функции:
Код - Visual Basic [Выбрать]
  1. Public Sub CenterViewHS(s As Sheet, name As String, startX As Double, endX As Double)
  2.     Log "CenterViewHS 1"
  3.    
  4.     Dim oView As DrawingView
  5.     Set oView = GetDrawingViewS(s, name)
  6.          
  7.     Log "CenterViewHS 2"
  8.    
  9.     Dim vx As Double
  10.     Dim vy As Double
  11.    
  12.     Dim vxc As Double
  13.    
  14.     Dim px As Double
  15.     Dim py As Double
  16.    
  17.     Log "CenterViewHS 3"
  18.    
  19.     vxc = oView.Center.X
  20.    
  21.     Log "CenterViewHS 4"
  22.    
  23.     vx = oView.Position.X
  24.    
  25.     Log "CenterViewHS 5"
  26.    
  27.     vy = oView.Position.Y
  28.    
  29.     Log "CenterViewHS 6"
  30.    
  31.     px = startX + (endX - startX) / 2 - (vxc - vx)
  32.     py = vy
  33.    
  34.     Log "CenterViewHS 7"
  35.    
  36.     Dim p As Point2d
  37.     Set p = ThisApplication.TransientGeometry.CreatePoint2d(px, py)
  38.    
  39.     Log "CenterViewHS 8"
  40.    
  41.     oView.Position = p
  42.    
  43.     Log "CenterViewHS 9"
  44. End Sub

Останавливается на команде: vxc = oView.Center.X

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

Оффлайн mikazakov

  • ADN
  • *
  • Сообщений: 654
  • Карма: 165
  • Skype: mikazakov@mail.ru
Re: Засыпает VBA-код при работе
« Ответ #7 : 25-08-2021, 16:00:09 »
Ну вот я потестил макрос, вызывал этот макрос из самого инвентора
Все работает нормально. На другом компьютере пробовали свой макрос запускать?

Код - Visual Basic [Выбрать]
  1. Public Sub CenterViewHS()
  2. '    Log "CenterViewHS 1"
  3.    Dim dd As DrawingDocument: Set dd = ThisApplication.ActiveDocument
  4.    
  5.     Dim oView As DrawingView
  6.     Set oView = dd.ActiveSheet.DrawingViews(1)
  7.          
  8. '    Log "CenterViewHS 2"
  9.    
  10.     Dim vx As Double
  11.     Dim vy As Double
  12.    
  13.     Dim vxc As Double
  14.    
  15.     Dim px As Double
  16.     Dim py As Double
  17.    
  18. '    Log "CenterViewHS 3"
  19.    
  20.     vxc = oView.Center.X
  21.    
  22. '    Log "CenterViewHS 4"
  23.    
  24.     vx = oView.Position.X
  25.    
  26. '    Log "CenterViewHS 5"
  27.    
  28.     vy = oView.Position.Y
  29.    
  30. '    Log "CenterViewHS 6"
  31.    
  32. '    px = startX + (endX - startX) / 2 - (vxc - vx)
  33. '    py = vy
  34. '
  35. '    Log "CenterViewHS 7"
  36.    
  37.     Dim p As Point2d
  38.     Set p = ThisApplication.TransientGeometry.CreatePoint2d(px, py)
  39.    
  40. '    Log "CenterViewHS 8"
  41.    
  42.     oView.Position = p
  43.    
  44. Debug.Print "CenterViewHS 9"
  45. End Sub

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

  • ADN OPEN
  • Сообщений: 12
  • Карма: 0
Re: Засыпает VBA-код при работе
« Ответ #8 : 25-08-2021, 16:54:31 »
Да, сейчас попробовали. Останавливается совсем в других местах...
Я думаю что просто Макрос уже на пределе. Код очень большой...
Нужно делать пытаться надстройку...

Оффлайн mikazakov

  • ADN
  • *
  • Сообщений: 654
  • Карма: 165
  • Skype: mikazakov@mail.ru
Re: Засыпает VBA-код при работе
« Ответ #9 : 25-08-2021, 17:31:00 »
Останавливается совсем в других местах...
Я думаю что просто Макрос уже на пределе. Код очень большой...
Ну странная штука конечно, хотя VBA имеет склонность тормозить, потому как VBA язык-интерпретатор. А сколько строк в "большом коде"?

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

  • ADN OPEN
  • Сообщений: 12
  • Карма: 0
Re: Засыпает VBA-код при работе
« Ответ #10 : 25-08-2021, 18:24:34 »
В основном модуле 3941, но он обращается к другим модулям...

Оффлайн mikazakov

  • ADN
  • *
  • Сообщений: 654
  • Карма: 165
  • Skype: mikazakov@mail.ru
Re: Засыпает VBA-код при работе
« Ответ #11 : 25-08-2021, 19:58:05 »
В основном модуле 3941, но он обращается к другим модулям...
Впечатляет