In theory xlErrorHandler should trap Esc but it rarely does. But I find the
method flakey, sometimes need to press Ctr-Break many times for it to catch.
This gives a bit more control & flexibility
Option Explicit
Public Declare Function GetInputState _
Lib "user32" () As Long
Public Declare Function GetAsyncKeyState _
Lib "user32" _
(ByVal vKey As Long) As Integer
Function IsKeyDown(key As Long) As Boolean
If GetAsyncKeyState(key) Then
IsKeyDown = True
End If
End Function
Function EscBreak() As Long
If IsKeyDown(vbKeyCancel) Then
EscBreak = vbKeyCancel '3
ElseIf IsKeyDown(vbKeyPause) Then
EscBreak = vbKeyPause '19
ElseIf IsKeyDown(vbKeyEscape) Then
EscBreak = vbKeyEscape '27
End If
End Function
Function UserBreak(nKeyPress As Long, Optional _
sInfo As String) As Boolean
Dim nEnblCancel As Long
Dim nScrUdate As Boolean
Dim sPrompt As String
Debug.Print "UserBreak1", Application.EnableCancelKey
nEnblCancel = Application.EnableCancelKey
nScrUdate = Application.ScreenUpdating
On Error GoTo errH:
Application.ScreenUpdating = True
Application.EnableCancelKey = xlErrorHandler
Select Case nKeyPress
Case 3: sPrompt = "Ctrl Break with API"
Case 18: sPrompt = "Ctrl Break xlErrorHandler"
Case 19: sPrompt = "Break without Ctrl"
Case 27: sPrompt = "Esc"
Case Else: '?
End Select
If Len(sInfo) Then
sPrompt = sInfo & vbCr & vbCr & sPrompt
End If
If MsgBox(sPrompt & vbCr & "continue :?", vbYesNo) = vbYes Then
UserBreak = True
End If
errH:
Application.EnableCancelKey = nEnblCancel
Application.ScreenUpdating = nScrUdate
End Function
Sub Test()
Dim i As Long, j As Long, cnt As Long
Dim nOuter As Long, nInner As Long
Dim nKey As Long
Dim s1$, s2$, sMsg$
s1 = "some test to a string"
nOuter = 5000
nInner = 1000
On Error GoTo errH
Application.EnableCancelKey = xlErrorHandler
For i = 1 To nOuter
For j = 1 To nInner
cnt = cnt + 1
s2 = cnt & " " & Left$(s1, 5) & Right$(s1, 6)
Next
Application.StatusBar = nOuter * nInner & " / " & cnt
If GetInputState Then
'GetInputState - v.quick check if some key pressed
nKey = EscBreak
If nKey 0 Then
Err.Raise 12345
End If
End If
Next
s2 = s2 & " completed"
cleanup:
MsgBox s2
Application.EnableCancelKey = xlInterrupt
Application.StatusBar = False
Exit Sub
errH:
sMsg = ""
If Err.Number = 18 Then nKey = 18
If nKey 0 Then
If UserBreak(nKey, _
Int(cnt * 100 / (nOuter * nInner)) & "% done") Then
Resume Next
End If
Else
MsgBox Err.Number & " " & Err.Description
End If
Resume cleanup
End Sub
Ron,
I think for your Esc to Cancel button event to work within a loop might need
to add DoEvents
Regards,
Peter T
"Tan" wrote in message
...
Thanks, but it doesn't work. I create a Cancel button and set cancel to
be
true, with a little piece of code that says "msgbox ("Cancel pressed")".
But
when I press the esc button, the message did not appear (ie, the code from
the cancel button did not execute. Any idea on how to resolve this?
"Ron de Bruin" wrote:
Maybe ?
You can add a button and set cancel to True
When you hit esc the code from the button will run.
--
Regards Ron de Bruin
http://www.rondebruin.nl
"Tan" wrote in message
...
I am on Excel 2002 and have a program that tries to trap the "Esc"
key,
using
Application.EnableCancelKey = xlErrorHandler
and trapping error 18:
If Err.Number = 18 Then
The program is called from a modal form.
The problem is that if the form has ShowModal=True, the Esc key cannot
be
trapped; while if the ShowModal of the form is False, then the system
can
trap the Esc key.
Control Break has no problem - ie it is trappable.
Any idea on how I can have a ShowModal=True form and yet, trap the esc
key?
Private Sub ExampleOfHow2HandleTheUserPressingCANCEL()
Dim iTest As Double, iCount As Double
On Error GoTo err_Sub
'xlDisabled = 0 'totally disables Esc / Ctrl-Break /
Command-Period
'xlInterrupt = 1 'go to debug
'xlErrorHandler = 2 'go to error handler
'Trappable error is #18
Application.EnableCancelKey = xlErrorHandler
'<<<<<<<<<<<<<<PUT YOUR CODE HERE
exit_Sub:
On Error Resume Next
Exit Sub
err_Sub:
If Err.Number = 18 Then
If MsgBox("You have stopped the process." & vbCr & vbCr & _
"QUIT now?", vbCritical + vbYesNo + vbDefaultButton1, _
"User Interrupt Occured...") = vbNo Then
Resume 'continue on from where error occured
End If
End If
GoTo exit_Sub
End Sub