模塊中：
Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Const GWL_WNDPROC = (-4)
Const WM_HOTKEY = &H312

Public Enum ModKeys
  MOD_ALT = &H1
  MOD_CONTROL = &H2
  MOD_SHIFT = &H4
  MOD_WIN = &H8
End Enum

Dim iAtom As Integer
Dim OldProc As Long, hOwner As Long
Public sDir As String, sFile As String

Public Function SetHotKey(hWin As Long, ModKey As ModKeys, vKey As Long) As Boolean
  If hOwner > 0 Then Exit Function
  hOwner = hWin
  iAtom = GlobalAddAtom("MyHotKey")
  SetHotKey = RegisterHotKey(hOwner, iAtom, ModKey, vKey)
  OldProc = SetWindowLong(hOwner, GWL_WNDPROC, AddressOf WndProc)
End Function

Public Sub RemoveHotKey()
  If hOwner = 0 Then Exit Sub
  Call UnregisterHotKey(hOwner, iAtom)
  Call SetWindowLong(hOwner, GWL_WNDPROC, OldProc)
End Sub

Public Function WndProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  If wMsg = WM_HOTKEY And wParam = iAtom Then
     ‘按了熱鍵后的操作
  Else
     WndProc = CallWindowProc(OldProc, hwnd, wMsg, wParam, lParam)
  End If
End Function

窗體中：
Private Sub Form_Load()
    SetHotKey Me.hwnd, MOD_CONTROL + MOD_SHIFT, vbKeyJ
End Sub

Private Sub Form_Unload(Cancel As Integer)
    RemoveHotKey
End Sub

以上代碼可以為一個(gè)應(yīng)用程序設(shè)定一個(gè)熱鍵，那么如何為一個(gè)應(yīng)用程序同時(shí)設(shè)定多個(gè)熱鍵呢？

 

 Dim WithEvents hk As clsRegHotKeys

Private Sub Form_Load()
    Set hk = New clsRegHotKeys
    hk.RegHotKeys Me.hwnd, AltKey, vbKeyA, "A"
    hk.RegHotKeys Me.hwnd, CtrlKey, vbKeyQ, "Q"
    Me.Show
    hk.WaitMsg
End Sub

Private Sub Form_Unload(Cancel As Integer)
    hk.UnWaitMsg
    Set hk = Nothing
End Sub

Private Sub hk_HotKeysDown(Key As String)
    If Key = "A" Then
        MsgBox "Alt+A"
    ElseIf Key = "Q" Then
        MsgBox "CTRL+Q"
    End If
End Sub

‘類(lèi)名 clsRegHotKeys

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 Type KeyMsg
    ID As Long  ‘ 保存注冊(cè)熱鍵時(shí)的ID
    Key As String ‘保存注冊(cè)熱鍵時(shí)的關(guān)鍵字
End Type

Private Const PM_REMOVE = &H1
Private Const WM_HOTKEY = &H312

Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal ID As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
‘id 值范圍 ：0X0000-0XBFFF
Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal ID As Long) As Long
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
‘************************************************************

Enum ShiftKeys
    AltKey = &H1
    CtrlKey = &H2
    ShiftKey = &H4
End Enum

‘局部變量
Private bCancel As Boolean
Private clsHwnd As Long
Private KeyGroup As Integer
Private KeyID As Long
Private Keys() As KeyMsg

‘聲明事件
Public Event HotKeysDown(Key As String)
‘注冊(cè)熱鍵,可以注冊(cè)多組熱鍵
Sub RegHotKeys(ByVal hwnd As Long, ByVal ShiftKey As ShiftKeys, ByVal ComKey As KeyCodeConstants, ByVal Key As String)
    On Error Resume Next
    clsHwnd = hwnd
    KeyID = KeyID + 1
    KeyGroup = KeyGroup + 1
    ReDim Preserve Keys(KeyGroup)
    RegisterHotKey hwnd, KeyID, ShiftKey, ComKey    ‘注冊(cè)熱鍵
    Keys(KeyGroup).ID = KeyID
    Keys(KeyGroup).Key = Trim(Key)
End Sub
‘取消熱鍵注冊(cè)
Sub UnRegHotKeys(ByVal Key As String)
    On Error Resume Next
    If KeyGroup = 0 Then Exit Sub
    Dim i As Integer
    For i = 0 To KeyGroup
        If Trim(Key) = Trim(Keys(i).Key) Then
            UnregisterHotKey clsHwnd, Keys(i).ID
        End If
    Next
End Sub

‘取消全部熱鍵注冊(cè)
Sub UnRegAllHotKeys()
    On Error Resume Next
    If KeyGroup = 0 Then Exit Sub
    Dim i As Integer
    For i = 0 To KeyGroup
        UnregisterHotKey clsHwnd, Keys(i).ID
    Next
End Sub

‘等候按鍵消息
Sub WaitMsg()
    On Error Resume Next
    bCancel = False
    Dim Message As Msg, i As Integer
    Do While Not bCancel
        WaitMessage ‘等候按鍵消息
        ‘判斷消息
        If PeekMessage(Message, clsHwnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then
            For i = 0 To KeyGroup
                If Keys(i).ID = Message.wParam Then ‘判斷按下哪組熱鍵
                    RaiseEvent HotKeysDown(Keys(i).Key) ‘引發(fā)事件
                End If
            Next
        End If
        DoEvents
    Loop
End Sub

‘取消等候消息
Sub UnWaitMsg()
    bCancel = True
End Sub

Private Sub Class_Initialize()
    KeyID = &H1000& ‘初始ID
    KeyGroup = -1
    ReDim Keys(0)
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    bCancel = True
    UnRegAllHotKeys
End Sub