Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,596
- Office Version
- 2016
- Platform
- Windows
Greetings all,
I put together a routine that handles Key strokes directed to worksheet cells and works in a similar fashion to that of the Keypress event of a TextBox control hence allowing data validation as you type-in among other things.
Someone correct me if i am wrong but using the VB RaiseEvent statement via a Class module doesn't seem to retrieve the value of the Cancel argument passed ByRef ! That would have been a more correct way of setting up the code. Instead I have just used a normal routine inside a Standard module which seems to work for the Cancel argument.
Workbook demo.
Anyway, here is the code that goes in a Standard module:
Note that unlike other Keyboard hooks,this method is not dangerous as it doesn't use subclassing, API timers or system wide hooks.
Any suggestions to improve on this are welcome.
Regards.
I put together a routine that handles Key strokes directed to worksheet cells and works in a similar fashion to that of the Keypress event of a TextBox control hence allowing data validation as you type-in among other things.
Someone correct me if i am wrong but using the VB RaiseEvent statement via a Class module doesn't seem to retrieve the value of the Cancel argument passed ByRef ! That would have been a more correct way of setting up the code. Instead I have just used a normal routine inside a Standard module which seems to work for the Cancel argument.
Workbook demo.
Anyway, here is the code that goes in a Standard module:
Code:
Option Explicit
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 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 TranslateMessage Lib "user32" _
(ByRef lpMsg As MSG) 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 Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Const WM_KEYDOWN As Long = &H100
Private Const PM_REMOVE As Long = &H1
Private Const WM_CHAR As Long = &H102
Private bExitLoop As Boolean
Sub StartKeyWatch()
Dim msgMessage As MSG
Dim bCancel As Boolean
Dim iKeyCode As Integer
Dim lXLhwnd As Long
[COLOR=seagreen]'handle the ESC key.[/COLOR]
On Error GoTo errHandler:
Application.EnableCancelKey = xlErrorHandler
[COLOR=seagreen]'initialize this boolean flag.[/COLOR]
bExitLoop = False
[COLOR=seagreen]'get the app hwnd.[/COLOR]
lXLhwnd = FindWindow("XLMAIN", Application.Caption)
Do
WaitMessage
[COLOR=seagreen]'check for a key press and remove it from the msg queue.[/COLOR]
If PeekMessage _
(msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
[COLOR=seagreen]'strore the virtual key code for later use.[/COLOR]
iKeyCode = msgMessage.wParam
[COLOR=seagreen]'translate the virtual key code into a char msg.[/COLOR]
TranslateMessage msgMessage
PeekMessage msgMessage, lXLhwnd, WM_CHAR, _
WM_CHAR, PM_REMOVE
[COLOR=seagreen]'for some obscure reason, the following[/COLOR]
[COLOR=seagreen] 'keys are not trapped inside the event handler[/COLOR]
[COLOR=seagreen]'so we handle them here.[/COLOR]
If iKeyCode = vbKeyBack Then SendKeys "{BS}"
If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
[COLOR=seagreen]'assume the cancel argument is False.[/COLOR]
bCancel = False
[COLOR=seagreen]'the VBA RaiseEvent statement does not seem to return ByRef arguments[/COLOR]
[COLOR=seagreen]'so we call a KeyPress routine rather than a propper event handler.[/COLOR]
Sheet_KeyPress _
ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection, bCancel
[COLOR=seagreen]'if the key pressed is allowed post it to the application.[/COLOR]
If bCancel = False Then
PostMessage _
lXLhwnd, msgMessage.Message, msgMessage.wParam, 0
End If
End If
errHandler:
[COLOR=seagreen]'allow the processing of other msgs.[/COLOR]
DoEvents
Loop Until bExitLoop
End Sub
Sub StopKeyWatch()
[COLOR=seagreen] 'set this boolean flag to exit the above loop.[/COLOR]
bExitLoop = True
End Sub
'[COLOR=seagreen]\\This example illustrates how to catch worksheet[/COLOR]
[COLOR=seagreen]'\\Key strokes in order to prevent entering numeric[/COLOR]
[COLOR=seagreen]'\\characters in the Range "A1:D10" .[/COLOR]
Private Sub Sheet_KeyPress _
(ByVal KeyAscii As Integer, ByVal KeyCode As Integer, _
ByVal Target As Range, Cancel As Boolean)
Const MSG As String = _
"Numeric Characters are not allowed in" & _
vbNewLine & "the Range: """
Const TITLE As String = "Invalid Entry !"
If Not Intersect(Target, Range("A1:D10")) Is Nothing Then
If Chr(KeyAscii) Like "[0-9]" Then
MsgBox MSG & Range("A1:D10").Address(False, False) _
& """ .", vbCritical, TITLE
Cancel = True
End If
End If
End Sub
[COLOR=seagreen]'\\This example illustrates how to catch a worksheet[/COLOR]
[COLOR=seagreen]'\\KeyPress to prevent entering Alpha characters in[/COLOR]
[COLOR=seagreen]'\\the range "A1:D10" .[/COLOR]
[COLOR=seagreen]'Private Sub Sheet_KeyPress _[/COLOR]
[COLOR=seagreen]'(ByVal KeyAscii As Integer, ByVal KeyCode As Integer, _[/COLOR]
[COLOR=seagreen]'ByVal Target As Range, Cancel As Boolean)[/COLOR]
[COLOR=seagreen]'[/COLOR]
[COLOR=seagreen]' Const MSG As String = "No Alpha-Characters are allowed in" & _[/COLOR]
[COLOR=seagreen]' vbNewLine & "Range: """[/COLOR]
[COLOR=seagreen]' Const TITLE As String = "Invalid Entry !"[/COLOR]
[COLOR=seagreen]'[/COLOR]
[COLOR=seagreen]' If Not Intersect(Target, Range("A1:D10")) Is Nothing Then[/COLOR]
[COLOR=seagreen]' If Chr(KeyAscii) Like "[a-z]" Or _[/COLOR]
[COLOR=seagreen]' Chr(KeyAscii) Like "[A-Z]" Then[/COLOR]
[COLOR=seagreen]' MsgBox MSG & Range("A1:D10").Address(False, False) _[/COLOR]
[COLOR=seagreen]' & """ .", vbCritical, TITLE[/COLOR]
[COLOR=seagreen]' Cancel = True[/COLOR]
[COLOR=seagreen]' End If[/COLOR]
[COLOR=seagreen]' End If[/COLOR]
[COLOR=seagreen]'[/COLOR]
[COLOR=seagreen]'End Sub[/COLOR]Note that unlike other Keyboard hooks,this method is not dangerous as it doesn't use subclassing, API timers or system wide hooks.
Any suggestions to improve on this are welcome.
Regards.
