Interrupt VBA while Running

Started by pavane, May 15, 2019, 08:58:40 AM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

pavane

Often I develop complex, long runing VBA macros for Visio.
During development, I sometimes forget to increment a loop counter (gasp!) or do a similar thing that
causes Visio VBA to go into an infinite loop. 
In these situations, I need to break the running VBA code, but neither ESC nor CTRL-BREAK does anything. 
Nor does Fn+B
The only alternative is to restart Visio, but this causes all unsaved work of the macro
to be lost (in addition to any unsaved code).
Is there an alternative to CTRL-BREAK to interrupt VBA?
(Maybe Like Excel Application.EnableCancelKey = xlErrorHandler)

Visio Guy

#1
The cheap way I used to do it is put in a counter and a break point like this:




'//...you are in a big, long loop...iCt is not the "For" variable!

If iCt = 10000 Then
  iCt = 0 '//...PUT A BREAK HERE (F9) Gives you a chance to stop.
Else
  iCt = iCt + 1
End If


Another way is to do things more "stately". Set up an event for VisioIsIdle or NoEventsPending, and allow your code to continue if a stop flag hasn't been set. On a visible form, put a button that sets the stop flag.
For articles, tips and free content, see the Visio Guy Website at http://www.visguy.com
Get my Visio Book! Using Microsoft Visio 2010

Visio Guy

#2
Attached is a file that shows example of interruptible drawing.

Highlights:


  • You can move the form while the rectangles are being drawn
  • The application event VisioIsIdle allows or disallows the drawing to continue
  • You might have to click the 'Stop' button several times to get it to work

I believe the execution is a bit slower by allowing VisioIsIdle to control the state, but you can comfortably pause or stop the code whenever you want, which is a huge advantage in some situations.

For the curious, and the search engines, here is the code. It is contained in two modules: ThisDocument and DrawRectanglesForm.

ThisDocument

Option Explicit

Private m_frm As DrawRectanglesForm

Private Sub Document_RunModeEntered( _
    ByVal visDoc As IVDocument)
   
  Call ShowForm(Nothing)
 
End Sub
Private Function Document_QueryCancelDocumentClose( _
      ByVal visDoc As IVDocument) As Boolean
 
  Set m_frm = Nothing
 
End Function

'// Note: Shape calls this proc from the ShapeSheet via:
'// EventDblClick = CALLTHIS("ThisDocument.ShowForm")
'//
Public Sub ShowForm(ByRef visShp As Visio.Shape)

  '// This code "simply" shows the form, or does
  '// nothing if the form is still open--we don't
  '// want multiple instances of the form.
 
  If (m_frm Is Nothing) Then
    Set m_frm = New DrawRectanglesForm
    Call m_frm.Show(False)
  Else
 
    '// Overly-complicated code to see if the form
    '// is still existant and valid:
    Dim frm As Object
    For Each frm In VBA.UserForms
      '// If we find "DrawRectanglesForm", then the
      '// form is still open:
      If (frm.Name = "DrawRectanglesForm") Then GoTo Cleanup
    Next frm
 
    '// We didn't find "DrawRectanglesForm" start over:
    Set m_frm = New DrawRectanglesForm
    Call m_frm.Show(False)
   
  End If
 
Cleanup:
  Set frm = Nothing
End Sub

Public Sub DeleteRectangles(ByRef visShp As Visio.Shape)

  Dim pg As Visio.Page
  Set pg = visShp.ContainingPage
 
  '// Get all of the shapes on the page:
  Dim sel As Visio.Selection
  Set sel = pg.CreateSelection(Visio.VisSelectionTypes.visSelTypeAll)
 
  '// Remove shapes that have "LockDelete=1"
  Dim shp As Visio.Shape
  Dim i As Integer
  For i = sel.Count To 1 Step -1
    Set shp = sel(i)
    If (shp.CellsU("LockDelete").ResultIU <> 0) Then
      Call sel.Select(shp, Visio.VisSelectArgs.visDeselect)
    End If
  Next i
 
  If (sel.Count > 0) Then
    Call sel.Delete
  End If

Cleanup:
  Set shp = Nothing
  Set pg = Nothing
  Set sel = Nothing
End Sub



DrawRectanglesForm

Here is the form, and a bit of action in the background. Those button-looking things at the top are actually shapes that you can double-click to show the form or delete all of the (other) rectangles.



and the code-behind:


Option Explicit

Private WithEvents m_visApp As Visio.Application

Private m_continue As Boolean
Private m_iRectangleCount As Long
Private m_iRectangleLimit As Long


'// ----- Form constructors/destructors ---------------------------------------
Private Sub UserForm_Initialize()
  m_continue = False
End Sub
Private Sub UserForm_Terminate()
  Set m_visApp = Nothing
End Sub

'// ----- Button procedures ---------------------------------------------------
Private Sub Button_Draw_Click()
  Call m_startDrawing
End Sub
Private Sub Button_stop_Click()
  Call m_stopDrawing
End Sub
Private Sub Button_Continue_Click()
  Call m_continueDrawing
End Sub

Private Sub Button_Exit_Click()
  Call Unload(Me)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Call Unload(Me)
End Sub


'// ----- Event Procedures ----------------------------------------------------
'Private Sub m_visApp_NoEventsPending(ByVal app As IVApplication)
'
'End Sub

'// Note: VisioIsIdle is more responsive than
'// NoEventsPending so our check-allow-stop code
'// goes here. Essentially, when Visio is idle (which
'// happens very frequently), this proc checks to see
'// if we should draw the next rectangle.
Private Sub m_visApp_VisioIsIdle(ByVal app As IVApplication)

  '// Should we draw the next rectangle?
 
  '// ...not if someone pushed the "stop" button:
  If (m_continue = False) Then Exit Sub

  '// ...not if we've already drawn a bazillion rectangles:
  If (m_iRectangleCount >= m_iRectangleLimit) Then
    Call m_stopDrawing
  Else
 
    '// This code isn't necessary, but you can put a
    '// break point at the Debug.Print line to stop
    '// the code every so often. Or you can watch the
    '// progress in the immediate window:
    Const CheckAt% = 200
    If (Int(m_iRectangleCount / CheckAt%) = (m_iRectangleCount / CheckAt%)) Then
      '// Set a break-point here if you want to
      '// stop every CheckAt% rectangles:
      Debug.Print m_iRectangleCount
    End If
   
  End If

  If (m_continue) Then
   
    '// Update the progress in the label:
    Me.Label_Status.Caption = m_iRectangleCount & " / " & m_iRectangleLimit
   
    '// Draw another rectangle:
    Call m_drawRandomRectangle(m_iRectangleCount)
    m_iRectangleCount = m_iRectangleCount + 1
   
  End If
 
End Sub


'// ----- Private Procedures --------------------------------------------------
Private Sub m_startDrawing()

  '// Get the rectangle limit from the text box:
  m_iRectangleLimit = VBA.Val(Me.TextBox_RectCt.Text)
  If (m_iRectangleLimit <= 0) Then m_iRectangleLimit = 1
 
  m_iRectangleCount = 0

  '// Or maybe here is a better place to initialize
  '// the WithEvents Visio App:
  Set m_visApp = Visio.Application
 
  '// Enable/disable buttons:
  Me.Button_Draw.Enabled = False
  Me.Button_Stop.Enabled = True
  Me.Button_Continue.Enabled = False
 
  m_continue = True
 
End Sub
Private Sub m_stopDrawing()

  m_continue = False
 
  '// Enable/disable buttons:
  Me.Button_Draw.Enabled = True
  Me.Button_Stop.Enabled = False
 
  If (m_iRectangleCount >= m_iRectangleLimit) Then
    '// We are done anyway!
    m_iRectangleCount = 0
    Me.Button_Continue.Enabled = False
  Else
    Me.Button_Continue.Enabled = True
  End If
 
 
  '// Get rid of the Visio event/object:
  Set m_visApp = Nothing
 
End Sub
Private Sub m_continueDrawing()

  '// Basically re-start the Visio events,
  '// but don't reset any counters:
  m_continue = True
  Set m_visApp = Visio.Application
 
  Me.Button_Draw.Enabled = False
  Me.Button_Stop.Enabled = True
  Me.Button_Continue.Enabled = False

End Sub

'// This is the procedure that actually does work.
'// We never run a For loop, but we set a counter
'// (m_iRectangleCount) and a limit flag (m_iRectangleLimit),
'// and check those each time this procedure is run.
Private Sub m_drawRandomRectangle(ByVal index As Long)

  On Error GoTo ErrorHandler

  '// Pick random rectangle widths and heights between
  '// 0.5 and 3 inches:
  VBA.Randomize
  Dim w As Double: w = 0.5 + 2.5 * VBA.Rnd
  Dim h As Double: h = 0.5 + 2.5 * VBA.Rnd
 
  '// Make sure the rectangles fit on the page:
  Dim l As Double: l = (11 - w) * VBA.Rnd
  Dim b As Double: b = (8.5 - h) * VBA.Rnd
 
  '// Turn off the undo buffer. Note: this clears out
  '// any items in the undo list, but it won't add all
  '// of the rectangles, text-sets, etc. to the undo list:
  Visio.Application.UndoEnabled = False
 
  '// Draw the shape, add the number as the shape's text:
  Dim shp As Visio.Shape
  Set shp = Visio.ActivePage.DrawRectangle(l, b, l + w, b + h)
  shp.Text = index
 
ErrorHandler:
  '// Turn undo back on at all costs!
  Visio.Application.UndoEnabled = True
Cleanup:
  Set shp = Nothing
End Sub


For articles, tips and free content, see the Visio Guy Website at http://www.visguy.com
Get my Visio Book! Using Microsoft Visio 2010

Yacine

A doevents helps catching the break interrupt.
Yacine

pavane

Thanks for the suggestions, but they all rely on identifying code which might loop. The program is so large and complex that this is not feasible. (It has many functions, including building a tree of test cases from an excel spreadsheet, and writing a Gherkin script fron the test case tree). A general way of interrupting the code is what I really need. In previous versions, I have been able to do this.