模块中:
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 以上代码可以为一个应用程序设定一个热键,那么如何为一个应用程序同时设定多个热键呢?
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 ‘类名 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 ‘ 保存注册热键时的ID Key As String ‘保存注册热键时的关键字 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) ‘注册热键,可以注册多组热键 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 ‘注册热键 Keys(KeyGroup).ID = KeyID Keys(KeyGroup).Key = Trim(Key) End Sub ‘取消热键注册 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 ‘取消全部热键注册
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) ‘引发事件 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 |
|