Can I capture and emulate a KeyDown event in Excel VBA?

前端 未结 2 1228
抹茶落季
抹茶落季 2021-02-06 09:25

Arun Singh gave a great answer to a similar question (Is there any event that fires when keys are pressed when editing a cell?). I want to set a flag to prevent execution of Sel

2条回答
  •  闹比i
    闹比i (楼主)
    2021-02-06 09:42

    It's pretty easy actually. I am demostrating it for UP and DOWN arrow key. You may add more to it like RIGHT/LEFT/TAB/ENTER etc... I have commented the part where you can add the keys.

    Paste this in the worksheet code area

    Option Explicit
    
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        If CancSelEvnt = False Then
            '
            '~~> Rest of the code for the Selection Change
            '
        Else
            '~~> Only for demostration purpose. Remove Msgbox later
            MsgBox "User pressed one of the navigation keys"
    
            CancSelEvnt = False
        End If
    End Sub
    

    Paste this in a module

    Option Explicit
    
    '~~> We need this as this will help us in cancelling the
    '~~> Selection chnage event
    Public CancSelEvnt As Boolean
    
    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
    
    Sub StartKeyWatch()
        Dim msgMessage As MSG
        Dim bCancel As Boolean
        Dim iKeyCode As Integer
        Dim lXLhwnd As Long
    
        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
    
                '
                '~~> This is the main part where we check what key is pressed
                '
    
                If iKeyCode = vbKeyDown Then   '<~~ Down
                    SendKeys "{DOWN}"
                    CancSelEvnt = True
                ElseIf iKeyCode = vbKeyUp Then '<~~ UP
                    SendKeys "{UP}"
                    CancSelEvnt = True
                '
                '~~> And so on for the rest of the navigation keys
                '
                Else
                    CancSelEvnt = False
                End If
    
                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
    

    And here is something that you may need ;)

    VBKey Code List

    vbKeyLButton    Left Mouse Button
    vbKeyRButton    Right Mouse Button
    vnKeyCancel     Cancel Key
    vbKeyMButton    Middle Mouse button
    vbKeyBack       Back Space Key
    vbKeyTab        Tab Key
    vbKeyClear      Clear Key
    vbKeyReturn     Enter Key
    vbKeyShift      Shift Key
    vbKeyControl    Ctrl Key
    vbKeyMenu       Menu Key
    vbKeyPause      Pause Key
    vbKeyCapital    Caps Lock Key
    vbKeyEscape     Escape Key
    vbKeySpace      Spacebar Key
    vbKeyPageUp     Page Up Key
    vbKeyPageDown   Page Down Key
    vbKeyEnd        End Key
    vbKeyHome       Home Key
    vbKeyLeft       Left Arrow Key
    vbKeyUp         Up Arrow Key
    vbKeyRight      Right Arrow Key
    vbKeyDown       Down Arrow Key
    vbKeySelect     Select Key
    vbKeyPrint      Print Screen Key
    vbKeyExecute    Execute Key
    vbKeySnapshot   Snapshot Key
    vbKeyInsert     Insert Key
    vbKeyDelete     Delete Key
    vbKeyHelp       Help Key
    vbKeyNumlock    Delete Key
    
    vbKeyA through vbKeyZ are the key code constants for the alphabet
    vbKey0 through vbKey9 are the key code constants for numbers
    vbKeyF1 through vbKeyF16 are the key code constants for the function keys
    vbKeyNumpad0 through vbKeyNumpad9 are the key code constants for the numeric key pad
    
    Math signs are:
    vbKeyMultiply      -  Multiplication Sign (*)
    vbKeyAdd             - Addition Sign (+)
    vbKeySubtract     - Minus Sign (-)
    vbKeyDecimal    - Decimal Point (.)
    vbKeyDivide        - Division sign (/)
    vbKeySeparator  - Enter (keypad) sign
    

    And Of course THIS msdn link for the key codes.

提交回复
热议问题