Cool Worksheet KeyDown Event (like the one for TextBoxes) & w/out Subclassing

[Jaafar Tribak]

Hi all,

I have been trying to create a keyDown event for worksheets for some time and i believe i have arrived at something that is probably worth sharing. This missing worksheet event can come in handy sometimes and i have seen a few requests for it but as we know,it's not possible to trap keyboard letters as you type them in an excel workshhet before leaving the cell concerned.Thre is just no such event.

here is a workbook demo:

http://www.savefile.com/files/2029271

for the record, here is the code. It goes in a Standard module :

 
Option Explicit
 
Const vbKeyBack = 8
Const vbKeyTab = 9
Const vbKeyClear = 12
Const vbKeyReturn = 13
Const vbKeyShift = 16
Const vbKeyControl = 17
Const vbKeyMenu = 18
Const vbKeyPause = 19
Const vbKeyCapital = 20
Const vbKeyEscape = 27
Const vbKeySpace = 32
Const vbKeyPageUp = 33
Const vbKeyPageDown = 34
Const vbKeyEnd = 35
Const vbKeyHome = 36
Const vbKeyLeft = 37
Const vbKeyUp = 38
Const vbKeyRight = 39
Const vbKeyDown = 40
Const vbKeySelect = 41
Const vbKeyPrint = 42
Const vbKeyExecute = 43
Const vbKeySnapshot = 44
Const vbKeyInsert = 45
Const vbKeyDelete = 46
Const vbKeyHelp = 47
Const vbKeyNumlock = 144
Const vbKeyF1 = 112
Const vbKeyF2 = 113
Const vbKeyF3 = 114
Const vbKeyF4 = 115
Const vbKeyF5 = 116
Const vbKeyF6 = 117
Const vbKeyF7 = 118
Const vbKeyF8 = 119
Const vbKeyF9 = 120
Const vbKeyF10 = 121
Const vbKeyF11 = 122
Const vbKeyF12 = 123
Const vbKeyF13 = 124
Const vbKeyF14 = 125
Const vbKeyF15 = 126
Const vbKeyF16 = 127
 
Private Type POINTAPI
    x As Long
    Y As Long
End Type
 
Private Type MSG
    hwnd As Long
    Message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type
 
Private Declare Function WaitMessage Lib "User32" () As Long
Private Declare Function TranslateMessage Lib "User32" _
(ByRef lpMsg As MSG) As Long
 
Private Declare Function PeekMessage Lib "User32" _
Alias "PeekMessageA" _
(ByRef lpMsg As MSG, ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long
 
 Private Declare Function FindWindow Lib _
"User32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Private Declare Function PostMessage Lib "User32" Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
 
Private Const WM_KEYDOWN = &H100
Private Const WM_CHAR As Long = &H102
Private Const PM_REMOVE As Long = &H1
Private Const PM_NOREMOVE = &H0
Private Const PM_NOYIELD As Long = &H2
 
Private bCancelLoop As Boolean
Private bCancel As Boolean
 
Sub StartEvent()
 
    Dim msgMessage As MSG
    Dim lHwnd As Long
 
    bCancelLoop = False
    'get the xl window handle
    lHwnd = FindWindow("XLMAIN", Application.Caption)
    'start loop to monitior key presses
    Do While Not bCancelLoop
        'wait for an input message.
        WaitMessage
        'check for a key press
        If PeekMessage _
            (msgMessage, lHwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
            'if the key pressed is a navigation ot Function key implement it
            If Is_Navigation_Or_Function_Key(msgMessage.wParam) _
            Then GoTo ImplementKey
            'for all other keys retrieve their ascii codes and
            'send them to our event handler
            TranslateMessage msgMessage
            PeekMessage msgMessage, lHwnd, WM_CHAR, _
            WM_CHAR, PM_REMOVE
            'reset flag
            bCancel = False
            Call Worksheet_OnKeyEvent(ActiveCell, Chr(msgMessage.wParam), bCancel)
            If Not bCancel Then
ImplementKey:
                'implement all wanted key presses by the user
                Call PostMessage(lHwnd, msgMessage.Message, msgMessage.wParam, 0)
            End If
        End If
        DoEvents
    Loop
    MsgBox "you terminated the OnKey Event", vbInformation
 
End Sub
 
Sub TerminateEvent()
 
    bCancelLoop = True
 
End Sub
 
Private Function Is_Navigation_Or_Function_Key(KeyCode As Long) As Boolean
 
    Dim vArRet As Variant
    Dim lRet As Long
 
    vArRet = Array(vbKeyBack, vbKeyTab, vbKeyClear, vbKeyReturn, vbKeyShift, _
    vbKeyControl, vbKeyMenu, vbKeyPause, vbKeyCapital, vbKeyEscape, _
    vbKeySpace, vbKeyPageUp, vbKeyPageDown, vbKeyEnd, vbKeyHome, _
    vbKeyLeft, vbKeyUp, vbKeyRight, vbKeyDown, vbKeySelect, vbKeyPrint, _
    vbKeyExecute, vbKeySnapshot, vbKeyInsert, vbKeyDelete, vbKeyHelp, _
    vbKeyNumlock, vbKeyF1, vbKeyF2, vbKeyF3, vbKeyF4, vbKeyF5, _
    vbKeyF6, vbKeyF7, vbKeyF8, vbKeyF9, vbKeyF10, vbKeyF11, vbKeyF12, _
    vbKeyF13, vbKeyF14, vbKeyF15, vbKeyF16)
 
    On Error Resume Next
    lRet = WorksheetFunction.Match(KeyCode, vArRet, 0)
    If Err.Number = 0 Then Is_Navigation_Or_Function_Key = True
 
End Function
 
'**** here is the OnKeyEvent handler ******
'this example will prevent the pressing of the "a" Key
'and will completly block any keyboad input into range A
'adapt the handler code as required like you do in
'standard excel native event.
 
Private Sub Worksheet_OnKeyEvent _
(ByRef InputCell As Range, ByRef Key As String, ByRef Cancel As Boolean)
 
    If Key = "a" Then
 
        Cancel = True
        MsgBox "You Can't Press the ""a"" Key", vbCritical
 
    End If
 
    If InputCell.Address = Range("a1").Address Then
 
        Cancel = True
        MsgBox "You can't edit cell 'A1'", vbExclamation
 
    End If
 
End Sub

Needs some more robust error handling. Open to comments & suggestions.

Regards.