A stable custom KeyPres event for worksheet cells

[Jaafar Tribak]

http://www.box.net/shared/ukx1l761taWorkbook demo

Hi all.

Ever wanted to have a keyPress event for worksheet cells just like those provided by ActiveX textbox controls so you can detect the keys as they are being typed in and act accordingly ?

Workarounds i've used so far involved using a keyboard hook, timers or continuos loops all of which tie up and slow down the application and can potentially crash the application if the project is reset while the code is running.

I've written this small dll whose bytes are stored within the workbook in a hidden worksheet. There is no need to register the dll (its all done on the fly) and more importantly the application seems to remain stable and no crashing is feared even if the code errors out or the VBE is reset !

The only requirement is that the Event procedure(OnKeyPress) MUST be located in the workbook module and MUST be Public to be seen by the dll code.

Code in the workbook module :

Option Explicit
 
Private Const DCOM_DLL_PATH_NAME As String _
= "C:\WINDOWS\system32\DirectCOM.dll"
 
Private Const JAAFAR_DLL_PATH_NAME As String _
= "C:\KeyPressWatcher.dll"

'CreateObject-Replacement (FileBased)
Private Declare Function GETINSTANCE Lib "DirectCom" _
(FName As String, ClassName As String) As Object

Private Declare Function UNLOADCOMDLL Lib "DirectCom" _
(FName As String, ClassName As String) As Long

Private oKeyPressInstance As Object


'=================================================================
'KeyPress custom event.
'Event Procedure Must be PUBLIC !!! and located in the workbook module.
'Use the ByRef Cancel argument to prevent the drop operation.

'Allow only Alpha characters in cell A1 of Sheets("test")
Public Sub OnKeyPress _
(ByVal Target As Range, ByVal KeyCode As Long, ByRef Cancel As Boolean)
    
    If ActiveSheet Is Sheets("test") Then
        If Target.Address = Range("a1").Address Then
            If IsNumeric(Chr(KeyCode)) Then
                MsgBox "No numeric characters are allowed in the range : " & _
                vbNewLine & Target.Address
                Cancel = True
            End If
        End If
    End If
    
End Sub
'=====================================================================


Private Sub Workbook_Open()

        'Create the DirectCom & KeyPressWatcher dlls.
        Call CreateDlls

        'load an instance of the 'KeyPressWatcher.dll' Class.
        Set oKeyPressInstance = _
        GETINSTANCE(JAAFAR_DLL_PATH_NAME, "KeyPressClass")

        If Not oKeyPressInstance Is Nothing Then
            'start watching user key strokes.
            Call oKeyPressInstance.Start(ThisWorkbook)
        Else
            MsgBox "Unable to load the " & _
            "'KeyPressWatcher' dll.", vbInformation
        End If

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    
    If Not oKeyPressInstance Is Nothing Then
        oKeyPressInstance.Finish
        Set oKeyPressInstance = Nothing
    End If

    UNLOADCOMDLL JAAFAR_DLL_PATH_NAME, "KeyPressClass"

    On Error Resume Next
    
    If Len(Dir(JAAFAR_DLL_PATH_NAME)) <> 0 Then
        Kill JAAFAR_DLL_PATH_NAME
    End If

End Sub



'Create the 'DirectCom' & 'KeyPressWatcher' dll from the
'Bytes stored in the '"DllBytes" hidden worksheet.
Private Sub CreateDlls()
 
    Dim Bytes() As Byte
    Dim lFileNum As Integer
    Dim aVar
    Dim x As Long
 
    On Error Resume Next
    
    If Len(Dir(JAAFAR_DLL_PATH_NAME)) = 0 Then
    
       With Worksheets("DllBytes")
           aVar = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value
       End With
     
       ReDim Bytes(LBound(aVar) To UBound(aVar))
       For x = LBound(aVar) To UBound(aVar)
           Bytes(x) = CByte(aVar(x, 1))
       Next
    
       lFileNum = FreeFile
       Open JAAFAR_DLL_PATH_NAME For Binary As #lFileNum
           Put #lFileNum, 1, Bytes
       Close lFileNum
    
    End If
    

    If Len(Dir(DCOM_DLL_PATH_NAME)) = 0 Then
    
        Erase Bytes
        
        With Worksheets("dllBytes")
            aVar = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)).Value
        End With
        
        ReDim Bytes(LBound(aVar) To UBound(aVar))
        For x = LBound(aVar) To UBound(aVar)
            Bytes(x) = CByte(aVar(x, 1))
        Next
        lFileNum = FreeFile
        Open DCOM_DLL_PATH_NAME For Binary As #lFileNum
            Put #lFileNum, 1, Bytes
        Close lFileNum
        
    End If
    

End Sub

Tested on Excel 2007 Win 7 only. Any feedback is much appreciated.

 

[Jaafar Tribak]

Jaafar,

I use Excel x64. I understand how WH_KEYBOARD_LL works globally, to listen for input events from the physical keyboard. The listening event is not only Excel specific. I have tried to initialize another Excel session with WH_KEYBOARD_LL to catch the event at the main thread, but no good result. Maybe, I should try again.

This may be of interest to you :

KeyPress Event for Worksheet Cells (Subclassing Without Crashing)

Hi dear forum. I am sure you are all familiar with the KeyPress and KeyDown events exposed by userform controls. These events not only allow the user to detect any keys being pressed dynamically, but also give the user the opportunity to discard (block) the key if so desired before it actually...

www.mrexcel.com

This method should work in x64bit excel unlike the legacy WH_KEYBOARD and WH_KEYBOARD_LL hooks.

 

[Jaafar Tribak]

Deleted - Duplicate by mistake

 

[Wazzateo]

@Jaafar Tribak
Thank you! Your shared article is highly applicable.