Home » excel » vba – Capture keypress completion event in a cell in an Excel worksheet

vba – Capture keypress completion event in a cell in an Excel worksheet

Posted by: admin May 14, 2020 Leave a comment


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:

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:

  1. “h”
  2. “he”
  3. “hel”
  4. “hell”
  5. “hello”

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

How to&Answers:

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)
        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
    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
            pTemp = pTemp & Chr(KeyAscii)
               Target.Offset(0) = pTemp
               Target.Offset(1) = pTemp
            Cancel = True
            Application.ScreenUpdating = True
        End If
    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 = ""
End Sub