Custom Worksheet KeyPress Event for catching Key strokes and data validating as you type into cells !

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,493
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:

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.
 

IsmaelPerez

New Member
Joined
Mar 5, 2015
Messages
2
How I can update the code to work with Excel 2010 64-bit? These changes do not work for me:
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
[COLOR=#ff8c00][B]#If VBA7 Then[/B][/COLOR]
   [COLOR=#ff8c00] Private Declare [B]PtrSafe [/B]Function WaitMessage Lib "user32" () As Long
    
    Private Declare [B]PtrSafe[/B] 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 [B]PtrSafe [/B]Function TranslateMessage Lib "user32" _
    (ByRef lpMsg As MSG) As Long
    
    Private Declare [B]PtrSafe [/B]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 [B]PtrSafe [/B]Function FindWindow Lib "user32" _
    Alias "FindWindowA" _
    (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long[/COLOR]
[COLOR=#ff8c00][B]#Else[/B][/COLOR]
    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
[COLOR=#ff8c00][B]#End If[/B][/COLOR]


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=#008000]   'handle the ESC key.[/COLOR]
    On Error GoTo errHandler:
    Application.EnableCancelKey = xlErrorHandler
[COLOR=#008000]   'initialize this boolean flag.[/COLOR]
    bExitLoop = False
[COLOR=#008000]   'get the app hwnd.[/COLOR]
    lXLhwnd = FindWindow("XLMAIN", Application.Caption)
    Do
        WaitMessage
[COLOR=#008000]       '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=#008000]           'strore the virtual key code for later use.[/COLOR]
            iKeyCode = msgMessage.wParam
[COLOR=#008000]           'translate the virtual key code into a char msg.[/COLOR]
            TranslateMessage msgMessage
            PeekMessage msgMessage, lXLhwnd, WM_CHAR, _
            WM_CHAR, PM_REMOVE
[COLOR=#008000]           'for some obscure reason, the following
            'keys are not trapped inside the event handler
            'so we handle them here.[/COLOR]
            If iKeyCode = vbKeyBack Then SendKeys "{BS}"
            If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
 [COLOR=#008000]           'assume the cancel argument is False.[/COLOR]
            bCancel = False
[COLOR=#008000]           'the VBA RaiseEvent statement does not seem to return ByRef arguments
            'so we call a KeyPress routine rather than a propper event handler.[/COLOR]
            Sheet_KeyPress _
            ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection, bCancel
[COLOR=#008000]           '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=#008000]  'allow the processing of other msgs.[/COLOR]
        DoEvents
    Loop Until bExitLoop


End Sub


Sub StopKeyWatch()
[COLOR=#008000]   'set this boolean flag to exit the above loop.[/COLOR]
    bExitLoop = True


End Sub




[COLOR=#008000]'\\This example illustrates how to catch worksheet
'\\Key strokes in order to prevent entering numeric
'\\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=#008000]'\\This example illustrates how to catch a worksheet
'\\KeyPress to prevent entering Alpha characters in
'\\the range "A1:D10" .[/COLOR]


[COLOR=#008000]'Private Sub Sheet_KeyPress _
'(ByVal KeyAscii As Integer, ByVal KeyCode As Integer, _
'ByVal Target As Range, Cancel As Boolean)
'
'    Const MSG As String = "No Alpha-Characters are allowed in" & _
'    vbNewLine & "Range:  """
'    Const TITLE As String = "Invalid Entry !"
'
'    If Not Intersect(Target, Range("A1:D10")) Is Nothing Then
'        If Chr(KeyAscii) Like "[a-z]" Or _
'        Chr(KeyAscii) Like "[A-Z]" Then
'            MsgBox MSG & Range("A1:D10").Address(False, False) _
'            & """ .", vbCritical, TITLE
'            Cancel = True
'        End If
'    End If
'
'End Sub
[/COLOR]
 

BillSikora

New Member
Joined
Apr 16, 2015
Messages
1
I get an error message saying user-defined type not defined with this bit of code highlighted: WithEvents CKeyWatcher As KeyPressApi

Any ideas?
 

Forum statistics

Threads
1,082,017
Messages
5,362,695
Members
400,686
Latest member
Aakash

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top