Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
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 :
Needs some more robust error handling. Open to comments & suggestions.
Regards.
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 :
Code:
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.
Last edited: