CODEWITHSUNDEEP
excelmacrosvba
Xhatahx
Xhatahx

Reputation: 5

A way to interrupt a macro at certain moments

I'm making a VBA macro that generates random numbers to find the most distant points on a cube. It works, but it often stumbles along for too long while doing nothing of any value, so I need to interrupt the macro sometimes.

However, I only want to interrupt at a certain moment, and the normal Ctrl+Break keyboard shortcut can interrupt the macro in the middle of a process, which can muck up the coordinate values I'm using. So I want a method to interrupt a macro at certain moments, preferably with a key press.

If needed, here is the code:

Sub optimize()
Dim Distance As Double
Dim OldNumber As Double
Dim OldNumbers(1 To 3) As Double
Dim l As Double
Dim n As Integer
Dim m As Integer
Distance = Range("H14").Value 'This cell contains the distance between the closest 2 points in the coordinates, using =MIN()
l = 0
LoopIt:
l = l + 1
For n = 0 To 7
For m = 0 To 2 'The coordinates are stored at F4:H11.
OldNumber = Range("F4").Offset(n, m).Value
If Rnd() > 0.01 Then
Range("F4").Offset(n, m).Value = OldNumber + Rnd() / 10000 - 0.00005 'Just slighty nudge the values...
Else
Range("F4").Offset(n, m).Value = Rnd() '...but only sometimes.
End If
If Range("F4").Offset(n, m).Value > 1 Then Range("F4").Offset(n, m).Value = 1
If Range("F4").Offset(n, m).Value < 0 Then Range("F4").Offset(n, m).Value = 0 'Making sure the values don't go too high or low
If Range("H14").Value >= Distance Then 'Are the closest points as far away as before? If so, that's Ok.
    If Range("H14").Value > Distance Then 'Are the closest points further away? If so, reset counter.
    l = 0
    End If
Distance = Range("H14").Value
Else 'Are the closest points closer? If so, reset.
Range("F4").Offset(n, m).Value = OldNumber
End If
Next m
OldNumbers(1) = Range("F4").Offset(n, 0).Value
OldNumbers(2) = Range("F4").Offset(n, 1).Value
OldNumbers(3) = Range("F4").Offset(n, 2).Value
Range("F4").Offset(n, 0).Value = Rnd()
Range("F4").Offset(n, 1).Value = Rnd()
Range("F4").Offset(n, 2).Value = Rnd() 'I don't know why I put this in, but it might become useful sometime.
If Range("H14").Value >= Distance Then 'Are the closest points as far away as before? If so, that's Ok.
    If Range("H14").Value > Distance Then 'Are the closest points further away? If so, reset counter.
    l = 0
    End If
Distance = Range("H14").Value
Else 'Are the closest points closer? If so, reset.
Range("F4").Offset(n, 0).Value = OldNumbers(1)
Range("F4").Offset(n, 1).Value = OldNumbers(2)
Range("F4").Offset(n, 2).Value = OldNumbers(3)
End If
Next n
'I only want to interrupt here.
If l > 10000 Then 'Has it found nothing for so long? Then quit.
'I sometimes adjust the barrier l needs to hit to very high values so it can compute on its own for a long ass-time without any input.
MsgBox ("Done!")
Exit Sub
End If
GoTo LoopIt
End Sub

Upvotes: 0

Views: 215

Answers (1)

Vegard
Vegard

Reputation: 4917

VoG of MrExcel seems to have a nice answer.

Type KeyboardBytes
    kbb(0 To 255) As Byte
End Type

Declare Function GetKeyboardState Lib "User32.DLL" (kbArray As KeyboardBytes) As Long

Sub StartLotteryDraw()
Dim kbArray As KeyboardBytes
Application.Cursor = xlWait
Do
    Calculate
    DoEvents
    GetKeyboardState kbArray
    If kbArray.kbb(32) And 128 Then
        Application.Cursor = xlNormal
        Exit Sub
    End If
Loop
End Sub

For your case, put this check at the end of your code, or if each iteration of the code takes so long that it doesn't detect your keypress, add a few checks throughout the code and use it to set a variable, then test for the variable at the end.

For example:

Type KeyboardBytes
    kbb(0 To 255) As Byte
End Type

Declare Function GetKeyboardState Lib "User32.DLL" (kbArray As KeyboardBytes) As Long

Add this line to your var declarations: 

Dim doInterrupt As Boolean

Place this line 3-4 places in your code, evenly spaced relative to how long the preceding code takes to execute: 

If doInterrupt = False Then doInterrupt = CheckInterrupt

Modify this part of your code: 

If l > 10000 Then

to something like this: 

If l > 1000000 Or doInterrupt = True Then

Finally, add this function after your code: 

Function CheckInterrupt() As Boolean
    Dim kb As KeyboardBytes
    GetKeyboardState kb

    If kb.kbb(32) And 128 Then CheckInterrupt = True
End Function

Upvotes: 2

Related Questions