Here is an example using the cells in column B.
procTestKey, written by Stephen Bullen and slightly modified:
1. waits for a keystroke
2. deposits the keystroke in the ActiveCell
3. shifts one cell to the right
The Event code calls procTestKey whenever a cell in column B is selected.
Here is the Event (worksheet) code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
Call procTestKey
End Sub
Here is my modification to Bullen's code:
'***************************************************************************
'* *
'* MODULE NAME: CHECK KEYBOARD BUFFER *
'* *
'* AUTHOR & DATE: STEPHEN BULLEN, (e-mail address removed) *
'* *
'* DESCRIPTION: This module contains an example of using Windows API *
'* calls to check the state of the message buffer. The *
'* example includes a check for "Key down" events, which *
'* are used to stop a loop. The module contains functions*
'* for both 16-bit and 32-bit versions of Windows. *
'* *
'***************************************************************************
Option Base 1
Option Explicit
'********************************************************************
'* DECLARE WINDOWS 16-BIT API CALLS *
'********************************************************************
'Type to hold the x and y coordinates of the mouse pointer
Type POINTAPI16
x As Integer
y As Integer
End Type
'Type to hold the Windows message information
Type MSG16
hWnd As Integer 'the window handle of the app
message As Integer 'the type of message (e.g. keydown, keyup etc)
wParam As Integer 'stores the key code
lParam As Long '?
time As Long 'time when message posted
pt As POINTAPI16 'coordinate of mouse pointer when messahe posted
End Type
'Find the window handle for this instance of Excel
Declare Function FindWindow16 Lib "User" Alias "FindWindow" (ByVal
lpClassName As String, _
ByVal lpWindowName As String) As Integer
'Look in the message buffer for a message
Declare Function PeekMessage16 Lib "User" Alias "PeekMessage" (lpMsg As
MSG16, _
ByVal hWnd As Integer, ByVal wMsgFilterMin As Integer, ByVal
wMsgFilterMax As Integer, _
ByVal wRemoveMsg As Integer) As Integer
'Translate the message from a virtual key code to a ASCII code
Declare Function TranslateMessage16 Lib "User" Alias "TranslateMessage"
(lpMsg As MSG16) As Integer
'********************************************************************
'* DECLARE WINDOWS 32-BIT API CALLS *
'********************************************************************
'Type to hold the x and y coordinates of the mouse pointer
Type POINTAPI32
x As Long
y As Long
End Type
'Type to hold the Windows message information
Type MSG32
hWnd As Long 'the window handle of the app
message As Long 'the type of message (e.g. keydown, keyup etc)
wParam As Long 'stores the key code
lParam As Long '?
time As Long 'time when message posted
pt As POINTAPI32 'coordinate of mouse pointer when messahe posted
End Type
'Find the window handle for this instance of Excel
Declare Function FindWindow32 Lib "USER32" Alias "FindWindowA" (ByVal
lpClassName As String, _
ByVal lpWindowName As String) As Long
'Look in the message buffer for a message
Declare Function PeekMessage32 Lib "USER32" Alias "PeekMessageA" (lpMsg As
MSG32, _
ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As
Long, _
ByVal wRemoveMsg As Long) As Long
'Translate the message from a virtual key code to a ASCII code
Declare Function TranslateMessage32 Lib "USER32" Alias "TranslateMessage"
(lpMsg As MSG32) As Long
'********************************************************************
'* Demo procedure to test the keyboard checking function *
'********************************************************************
Sub procTestKey()
Dim sKey As String
'Just loop until a key is pressed
Do
'Call the appropriate routine to check the keyboard buffer
If InStr(1, Application.OperatingSystem, "32") = 0 Then
sKey = funCheckKey16
Else
sKey = funCheckKey32
End If
Loop Until sKey <> ""
ActiveCell.Value = sKey
ActiveCell.Offset(0, 1).Select
End Sub
'***************************************************************************
'* *
'* FUNCTION NAME: CHECK KEYBOARD BUFFER - 16 BIT *
'* AUTHOR & DATE: STEPHEN BULLEN, 9 APRIL 1996 *
'* *
'* DESCRIPTION: This function uses Windows API calls to check if there *
'* are any 'Key down' messages for the application. If *
'* there are some, it returns the key pressed as a string *
'* *
'***************************************************************************
Function funCheckKey16() As String
'Dimension variables
Dim msgMessage As MSG16
Dim iHwnd As Integer
Dim i As Integer
'Dimension Windows API constants
Const WM_CHAR As Integer = &H102
Const WM_KEYDOWN As Integer = &H100
Const PM_REMOVE As Integer = &H1
Const PM_NOYIELD As Integer = &H2
'Default to no key pressed
funCheckKey16 = ""
'Get the window handle of this application
iHwnd = FindWindow16("XLMAIN", Application.Caption)
'See if there are any "Key down" messages
i = PeekMessage16(msgMessage, iHwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE +
PM_NOYIELD)
'If so ...
If i <> 0 Then
'... translate the virtual key code to a character code ...
i = TranslateMessage16(msgMessage)
'... and get the character code message
i = PeekMessage16(msgMessage, iHwnd, WM_CHAR, WM_CHAR, PM_REMOVE +
PM_NOYIELD)
'Return the character of the key pressed
funCheckKey16 = Chr(msgMessage.wParam)
End If
End Function
'***************************************************************************
'* *
'* FUNCTION NAME: CHECK KEYBOARD BUFFER - 32 BIT *
'* AUTHOR & DATE: STEPHEN BULLEN, 9 APRIL 1996 *
'* *
'* DESCRIPTION: This function uses Windows API calls to check if there *
'* are any 'Key down' messages for the application. If *
'* there are some, it returns the key pressed as a string *
'* *
'***************************************************************************
Function funCheckKey32() As String
'Dimension variables
Dim msgMessage As MSG32
Dim iHwnd As Long
Dim i As Long
'Dimension Windows API constants
Const WM_CHAR As Long = &H102
Const WM_KEYDOWN As Long = &H100
Const PM_REMOVE As Long = &H1
Const PM_NOYIELD As Long = &H2
'Default to no key pressed
funCheckKey32 = ""
'Get the window handle of this application
iHwnd = FindWindow32("XLMAIN", Application.Caption)
'See if there are any "Key down" messages
i = PeekMessage32(msgMessage, iHwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE +
PM_NOYIELD)
'If so ...
If i <> 0 Then
'... translate the virtual key code to a character code ...
i = TranslateMessage32(msgMessage)
'... and get the character code message
i = PeekMessage32(msgMessage, iHwnd, WM_CHAR, WM_CHAR, PM_REMOVE +
PM_NOYIELD)
'Return the character of the key pressed
funCheckKey32 = Chr(msgMessage.wParam)
End If
End Function
If you copy/paste this stuff, pay attention to line-wrapping. Bullen's
website:
http://www.oaltd.co.uk/Excel/Default.htm
is a great place to rummage.
