22

ワークシートの特定のセルでキーを押す (編集する)ときに、何らかの方法でイベントをキャプチャすることは可能ですか?

最も近いものはChangeイベントですが、編集されたセルの選択が解除されるとすぐにアクティブ化できます。セルの編集中にイベントをキャプチャしたい。

4

3 に答える 3

24

これが答えです。私は同じことをテストしましたが、私にとっては適切に機能しています。

Excel でキープレスを追跡する

興味深い質問: MS Excel のWorksheet_Changeイベントは、変更が完了してセルから出ると、常に発生します。イベントをトラップしKey Pressます。Excel の標準関数または組み込み関数では、Keypress イベントの追跡はできません。

これは、 を使用して実現できますAPI。

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

Sub TrackKeyPressInit()

    Dim msgMessage As MSG
    Dim bCancel As Boolean
    Dim iKeyCode As Integer
    Dim lXLhwnd As Long

    On Error GoTo errHandler:
        Application.EnableCancelKey = xlErrorHandler
        'initialize this boolean flag.
        bExitLoop = False
        'get the app hwnd.
        lXLhwnd = FindWindow("XLMAIN", Application.Caption)
    Do
        WaitMessage
        'check for a key press and remove it from the msg queue.
        If PeekMessage _
            (msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
            'strore the virtual key code for later use.
            iKeyCode = msgMessage.wParam
           'translate the virtual key code into a char msg.
            TranslateMessage msgMessage
            PeekMessage msgMessage, lXLhwnd, WM_CHAR, _
            WM_CHAR, PM_REMOVE
           'for some obscure reason, the following
          'keys are not trapped inside the event handler
            'so we handle them here.
            If iKeyCode = vbKeyBack Then SendKeys "{BS}"
            If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
           'assume the cancel argument is False.
            bCancel = False
            'the VBA RaiseEvent statement does not seem to return ByRef arguments
            'so we call a KeyPress routine rather than a propper event handler.
            Sheet_KeyPress _
            ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection, bCancel
            'if the key pressed is allowed post it to the application.
            If bCancel = False Then
                PostMessage _
                lXLhwnd, msgMessage.Message, msgMessage.wParam, 0
            End If
        End If
errHandler:
        'allow the processing of other msgs.
        DoEvents
    Loop Until bExitLoop

End Sub

Sub StopKeyWatch()

    'set this boolean flag to exit the above loop.
    bExitLoop = True

End Sub


'\\This example illustrates how to catch worksheet
'\\Key strokes in order to prevent entering numeric
'\\characters in the Range "A1:D10" .
Private Sub Sheet_KeyPress(ByVal KeyAscii As Integer, _
                           ByVal KeyCode As Integer, _
                           ByVal Target As Range, _
                           Cancel As Boolean)

    Const MSG As String = _
    "Numeric Characters are not allowed in" & _
    vbNewLine & "the Range:  """
    Const TITLE As String = "Invalid Entry !"

    If Not Intersect(Target, Range("A1:D10")) Is Nothing Then
        If Chr(KeyAscii) Like "[0-9]" Then
            MsgBox MSG & Range("A1:D10").Address(False, False) _
            & """ .", vbCritical, TITLE
            Cancel = True
        End If
    End If

End Sub
于 2012-06-22T10:16:10.273 に答える
4

これは古い質問であることは知っていますが、最近同様の機能が必要であり、提供された回答にはいくつかの制限があり、Del、Backspace、Function キーなどを処理する (または処理しなかった) 方法で対処する必要がありました。

修正は、翻訳されたメッセージの代わりに元のメッセージをポストバックすることです。

また、Excel 2010 で正常に動作し、同じコードを複数のシートにコピーしたくなかったため、イベントを含むクラス モジュールを使用するように変更しました。

クラス モジュール (KeyPressApi という名前)

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 Event KeyPressed
    (ByVal KeyAscii As Integer, _
     ByVal KeyCode As Integer, _
     ByVal Target As Range, _
     ByRef Cancel As Boolean)

Public Sub StartKeyPressInit()
    Dim msgMessage As MSG
    Dim bCancel As Boolean
    Dim iMessage As Integer
    Dim iKeyCode As Integer
    Dim lXLhwnd As Long

    On Error GoTo errHandler
    Application.EnableCancelKey = xlErrorHandler
    'Initialize this boolean flag.
    bExitLoop = False
    'Get the app hwnd.
    lXLhwnd = FindWindow("XLMAIN", Application.Caption)
    
    Do
        WaitMessage
        
        'Exit the loop if we were aborted
        If bExitLoop Then Exit Do
        
        'Check for a key press and remove it from the msg queue.
        If PeekMessage(msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
            'Store the virtual key code for later use.
            iMessage = msgMessage.Message
            iKeyCode = msgMessage.wParam

            'Translate the virtual key code into a char msg.
            TranslateMessage msgMessage
            PeekMessage msgMessage, lXLhwnd, WM_CHAR, WM_CHAR, PM_REMOVE
            
            bCancel = False
            RaiseEvent KeyPressed(msgMessage.wParam, iKeyCode, Selection, bCancel)
            
            'If not handled, post back to the window using the original values
            If Not bCancel Then
                PostMessage lXLhwnd, iMessage, iKeyCode, 0
            End If
        End If
errHandler:
        'Allow the processing of other msgs.
        DoEvents
    Loop Until bExitLoop
End Sub

Public Sub StopKeyPressWatch()
    'Set this boolean flag to exit the above loop.
    bExitLoop = True
End Sub

使用法

Option Explicit

Dim WithEvents CKeyWatcher As KeyPressApi

Private Sub Worksheet_Activate()
    If CKeyWatcher Is Nothing Then
        Set CKeyWatcher = New KeyPressApi
    End If
    CKeyWatcher.StartKeyPressInit
End Sub

Private Sub Worksheet_Deactivate()
    CKeyWatcher.StopKeyPressWatch
End Sub

'\\This example illustrates how to catch worksheet
'\\Key strokes in order to prevent entering numeric
'\\characters in the Range "A1:D10" .
Private Sub CKeyWatcher_KeyPressed(ByVal KeyAscii As Integer, _
                                   ByVal KeyCode As Integer, _
                                   ByVal Target As Range, _
                                   Cancel As Boolean)

    Const MSG As String = _
    "Numeric Characters are not allowed in" & _
    vbNewLine & "the Range:  """
    Const TITLE As String = "Invalid Entry !"

    If Not Intersect(Target, Range("A1:D10")) Is Nothing Then
        If Chr(KeyAscii) Like "[0-9]" Then
            MsgBox MSG & Range("A1:D10").Address(False, False) _
            & """ .", vbCritical, TITLE
            Cancel = True
        End If
    End If

End Sub
于 2014-10-02T15:12:38.030 に答える
3

同じ問題があり、セルの上にテキスト ボックスを配置して解決しました。テキスト ボックスが Excel セルのように見えるようにプロパティを設定し、Top プロパティと Left プロパティを使用して、セルと同じプロパティを使用してセルの上に配置し、Width と Height をそれよりも 1 大きい値に設定しました。細胞。それから私はそれを見えるようにしました。KeyDown イベントを使用してキーストロークを処理しました。私のコードでは、セルの下にリスト ボックスを配置して、リストから一致するアイテムを別のシートに表示しました。注: このコードはシートにあり、Cell 変数はモジュールで宣言されています: Global Cell as Range. これは、コンボ ボックスよりもはるかにうまく機能します。tb1 はテキスト ボックス、lb1 はリスト ボックスです。最初の列にデータを含む Fruit という名前のシートが必要です。このコードが実行されるシートは、選択したセルが列 = 2 にあり、空の場合にのみ実行されます。

Option Explicit

Private Sub lb1_Click()
  Cell.Value2 = lb1.Value
  tb1.Visible = False
  lb1.Visible = False
  Cell.Activate
End Sub

Private Sub tb1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim Row As Long
Dim Temp As String
  Select Case KeyCode
  Case vbKeyBack
    If Len(tb1.Value) > 0 Then tb1.Value = Left(tb1.Value, Len(tb1.Value) - 1)
  Case vbKeySpace, vbKeyA To vbKeyZ
    tb1.Value = WorksheetFunction.Proper(tb1.Value & Chr(KeyCode))
  Case vbKeyReturn
    If lb1.ListCount > 0 Then
      Cell.Value2 = lb1.List(0)
    Else
      Cell.Value2 = tb1.Value
      With Sheets("Fruit")
        .Cells(.UsedRange.Rows.Count + 1, 1) = tb1.Value
        .UsedRange.Sort Key1:=.Cells(1, 1), Header:=xlYes
      End With
      MsgBox tb1.Value & " has been added to the List"
    End If
    tb1.Visible = False
    lb1.Visible = False
    Cell.Activate
  Case vbKeyEscape
    tb1.Visible = False
    lb1.Visible = False
    Cell.Activate
  End Select
  lb1.Clear
  Temp = LCase(tb1.Value) & "*"
  With Sheets("Fruit")
    For Row = 2 To .UsedRange.Rows.Count
      If LCase(.Cells(Row, 1)) Like Temp Then
        lb1.AddItem .Cells(Row, 1)
      End If
    Next Row
  End With
KeyCode = 0
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  If Target.Column = 2 And Target.Cells.Count = 1 Then
    If Target.Value2 = Empty Then
      Set Cell = Target
      With Cell
        tb1.Top = .Top
        tb1.Left = .Left
        tb1.Height = .Height + 1
        tb1.Width = .Width + 1
      End With
      tb1.Value = Empty
      tb1.Visible = True
      tb1.Activate
      With Cell.Offset(1, 0)
        lb1.Top = .Top
        lb1.Left = .Left
        lb1.Width = .Width + 1
        lb1.Clear
        lb1.Visible = True
      End With
    Else
      tb1.Visible = False
      lb1.Visible = False
    End If
  Else
    tb1.Visible = False
    lb1.Visible = False
  End If
End Sub
于 2017-05-26T02:05:41.827 に答える