Capture keypress completion event in a cell in an Excel worksheet

Question

Is there a way with VBA to capture the event after a key has been pressed in an Excel worksheet?

There was a similar question answered here: Is there any event that fires when keys are pressed when editing a cell?
This is the demo workbook with the answer: http://www.321webs.com/download/30478.htm

This works for capturing the keypress event, to check and potentially stop the keypress, but I want to allow all keypresses and just trigger an event after each one.

The purpose is to capture the cell value as the user types. If the user is typing "hello" then an event is triggered at these states of the target cell:

"h"
"he"
"hel"
"hell"
"hello"

and if the user uses the backspace or delete, it captures the cell content after each of these instances too.

Please share how you tried to adapt that answer to your needs. — BigBen, Jul 17 '19 at 15:19
For example, if a cell had "h" then there was keypress "e", then I attempted to concatenate with the existing and change the target cell to "he" with events turned off. This completely didn't work. — Vlad, Jul 17 '19 at 15:21
Do you have one particular cell you are writing in, and you need to capture from? — JvdV, Jul 17 '19 at 15:30
I check if the cell is in a named range using intersection. If it is outside that range I turn off the keypress event checking. — Vlad, Jul 17 '19 at 15:45

Dmitrij Holkin · Accepted Answer · 2019-07-18T08:10:14.187

so what wrong with your posted example?, lets make a litlle corrections.

Put this to module

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


Public pTemp As String
Public GlobalArray As Variant


Sub TrackKeyPressInit()

    Dim msgMessage As MSG
    Dim bCancel As Boolean
    Dim iKeyCode As Integer
    Dim lXLhwnd As Long
    GlobalArray = Array(19, 20, 46, 40, 35, 13, 27, 36, 45, 37, 144, 34, 33, 39, 145, 9, 38)
        'BACKSPACE  8
        'BREAK  19
        'CAPS LOCK  20
        'DELETE 46
        'DOWN ARROW 40
        'END    35
        'ENTER 13
        'ESC    27
        'HOME   36
        'INS    45
        'LEFT ARROW 37
        'NUM LOCK   144
        'PAGE DOWN  34
        'PAGE UP    33
        'RIGHT ARROW    39
        'SCROLL LOCK    145
        'TAB    9
        'UP ARROW   38
    On Error GoTo errHandler:
        Application.EnableCancelKey = xlErrorHandler
        bExitLoop = False
        lXLhwnd = FindWindow("XLMAIN", Application.Caption)
    Do
        WaitMessage
        If PeekMessage _
            (msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
            iKeyCode = msgMessage.wParam
            TranslateMessage msgMessage
            PeekMessage msgMessage, lXLhwnd, WM_CHAR, WM_CHAR, PM_REMOVE
            If iKeyCode = vbKeyBack Then SendKeys "{BS}"
            'If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
            bCancel = False
            Sheet_KeyPress ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection, bCancel
            If bCancel = False Then
                PostMessage lXLhwnd, msgMessage.Message, msgMessage.wParam, 0
            End If
        End If
errHandler:
        DoEvents
    Loop Until bExitLoop

End Sub

Sub StopKeyWatch()
    bExitLoop = True
End Sub

Private Sub Sheet_KeyPress(ByVal KeyAscii As Integer, _
                           ByVal KeyCode As Integer, _
                           ByVal Target As Range, _
                           Cancel As Boolean)

    If Not Intersect(Target, Range("A1:D10")) Is Nothing Then
        If IsInArray(KeyAscii, GlobalArray) Then
            StopKeyWatch ' exit if pressed key in globalscope (restricted)
            Cancel = True
            SendKeys "{ENTER}" ' UPDATE CELL
        Else
            pTemp = pTemp & Chr(KeyAscii)
               Target.Offset(0) = pTemp
               Target.Offset(1) = pTemp
            Cancel = True
            Application.ScreenUpdating = True
        End If
    Else
        StopKeyWatch
    End If

End Sub

Function IsInArray(stringToBeFound As Integer, arr As Variant) As Boolean
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

And put this to active sheet

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    pTemp = ""
    TrackKeyPressInit
End Sub

This works for message box `MsgBox pTemp`. Is it possible to make it work with `Target.Offset(1) = pTemp` to have the cell below mirror the contents of the cell being edited? I've tried and it works only for the first letter then doesn't allow more keystrokes. — Vlad, Jul 18 '19 at 00:24

Capture keypress completion event in a cell in an Excel worksheet

1 Answers1