Displaying KeyCode on a Sheet

[villy]

Hi once again,
I know this one will be interesting topic again for all gurus and first time learner of vba in excel.
What I want to know, is there any program of something like if i press characters or anything in the keyboard it displays its corresponding keycode in the cell.

For example: If I hit A in my keyboard I want let say in cell A1 to display the keycode of A.
If i hit arrow up then in a cell will display its keycode.

Any idea gurus?
Thanks in advance.

it's me Villy

 

[villy]

Anyone have thoughts about this?
Thanks

 

[Jaafar Tribak]

This is a weird request but for the sake of interest here is one way :

In a Standard module : Run the (StartHook Macro)

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 TranslateMessage Lib "user32" _
(ByRef lpMsg As MSG) 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 Sub mouse_event Lib "user32" _
(ByVal dwFlags As Long, _
ByVal dx As Long, _
ByVal dy As Long, _
ByVal cButtons As Long, _
ByVal dwExtraInfo As Long)

 
Private Const WM_KEYDOWN = &H100
Private Const WM_CHAR As Long = &H102
Private Const PM_REMOVE As Long = &H1
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
 
Private bCancelLoop As Boolean
Private bHookSet As Boolean

Sub StartHook()

   If Not bHookSet Then
       bHookSet = True
       Call HookKeyBoard
   End If
   
End Sub
 
Sub TerminateHook()
 
    'reset flags.
    bCancelLoop = True
    bHookSet = False
 
End Sub


 
Private Sub HookKeyBoard()
 
    Dim msgMessage As MSG
    
    'initialize the flag.
    bCancelLoop = False
    Application.OnDoubleClick = "CANCEL_DBLCLCK"
    Application.EnableCancelKey = xlDisabled
    'start loop to monitior key presses.
    Do While Not bCancelLoop
        'wait for an input message.
        WaitMessage
        'check for a key press.
        If PeekMessage _
        (msgMessage, 0, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
        'for all other keys retrieve their ascii codes and
        TranslateMessage msgMessage
        PeekMessage msgMessage, 0, WM_CHAR, _
        WM_CHAR, PM_REMOVE
        'send the KeyCodes to the worksheet.
        ActiveCell = "'" & CStr(ActiveCell) & CStr(msgMessage.wParam)
        End If
        'allow processing other msgs.
        DoEvents
    Loop
    Application.EnableCancelKey = xlInterrupt
    Application.OnDoubleClick = ""
    MsgBox "Done.", vbInformation
 
End Sub
 

Private Sub CANCEL_DBLCLCK()

    mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, _
    0&, 0&, 0&, 0&
    DoEvents
    
End Sub

You can easily amend this to work for a specific Worksheet/Range.

 

[villy]

This works great...
Thanks I can use this in one of my program actually.
Thanks again.
Maybe You can take a look at my other thread too.

 

[villy]

Is there an explanation why ALT key is not displaying any keycode?
Thanks

 

[Jaafar Tribak]

Is there an explanation why ALT key is not displaying any keycode?
Thanks

The ALT key is a System key so it won't be trapped with that code.

If you want to trap the ALT key as well then use the code below :

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 TranslateMessage Lib "user32" _
(ByRef lpMsg As MSG) 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 Sub mouse_event Lib "user32" _
(ByVal dwFlags As Long, _
ByVal dx As Long, _
ByVal dy As Long, _
ByVal cButtons As Long, _
ByVal dwExtraInfo As Long)

Private Const WM_SYSKEYDOWN As Long = &H104
Private Const WM_KEYDOWN = &H100
Private Const WM_CHAR As Long = &H102
Private Const PM_REMOVE As Long = &H1
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
 
Private bCancelLoop As Boolean
Private bHookSet As Boolean
 
Sub StartHook()

   If Not bHookSet Then
       bHookSet = True
       Call HookKeyBoard
   End If
   
End Sub
 
Sub TerminateHook()
 
    'reset flags.
    bCancelLoop = True
    bHookSet = False
 
End Sub


 
Private Sub HookKeyBoard()
 
    Dim msgMessage As MSG
    
    'initialize the flag.
    bCancelLoop = False
    Application.OnDoubleClick = "CANCEL_DBLCLCK"
    Application.EnableCancelKey = xlDisabled
    'start loop to monitior key presses.
    Do While Not bCancelLoop
        'wait for an input message.
        WaitMessage
        'check for a key press.
        If PeekMessage _
        (msgMessage, 0, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Or _
         PeekMessage(msgMessage, 0, WM_SYSKEYDOWN, _
        WM_SYSKEYDOWN, PM_REMOVE) _
        Then
        'for all other keys retrieve their ascii codes and
        TranslateMessage msgMessage
        PeekMessage msgMessage, 0, WM_CHAR, _
        WM_CHAR, PM_REMOVE
        'send the KeyCodes to the worksheet.
        ActiveCell = "'" & CStr(ActiveCell) & "-" & CStr(msgMessage.wParam)
        End If
        'allow processing other msgs.
        DoEvents
    Loop
    Application.EnableCancelKey = xlInterrupt
    Application.OnDoubleClick = ""
    MsgBox "Done.", vbInformation
 
End Sub
 

Private Sub CANCEL_DBLCLCK()

    mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, _
    0&, 0&, 0&, 0&
    DoEvents
    
End Sub

 

[villy]

Thanks you're an inspiration...

 

[Yahya]

Jaafar
It is nice code my friend

Ramdan Kareem

كل عام و أنت بخير

 

[villy]

Hope you can visit and take a look at my other thread about Run-time error.

Thanks

 

[Jaafar Tribak]

jaafar
it is nice code my friend

ramdan kareem

كل عام و أنت بخير

جزاك الله خيرا يا أستاد يحيى و رمضان مبارك لك و لأسرتك