-
Notifications
You must be signed in to change notification settings - Fork 5
/
Copy pathmdlhotkeys.bas
141 lines (109 loc) · 4.56 KB
/
mdlhotkeys.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
Attribute VB_Name = "mdlhotkeys"
' .01 mdlhotkeys.bas DAEB 27/01/2021 Added the hotkeys module to support system wide keypresses
'------------------------------------------------------------
' mdlhotkeys.bas
'
' Author: Aaron Young
' Origin: Written
' Purpose: Register system wide hotkeys
'
'------------------------------------------------------------
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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
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 UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WH_GETMESSAGE = 3
Private Const WM_HOTKEY = &H312
Public Const MOD_ALT = &H1
Public Const MOD_CONTROL = &H2
Public Const MOD_SHIFT = &H4
Private lHookID As Long
Public lHotKeys As Long
' .01 mdlhotkeys.bas DAEB 27/01/2021 Added the hotkeys module to support system wide keypresses
'---------------------------------------------------------------------------------------
' Procedure : CallBackHook
' Author : beededea
' Date : 28/01/2021
' Purpose :
'---------------------------------------------------------------------------------------
'
Private Function CallBackHook(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tMSG As Msg
On Error GoTo CallBackHook_Error
CopyMemory tMSG, ByVal lParam, Len(tMSG)
If tMSG.message = WM_HOTKEY And wParam Then
'Execute whatever for the HotKey here
dock.lPressed = tMSG.wParam
'dock.Command1_Click
'MsgBox "You pressed the Hotkey with the ID of: " & lPressed, vbSystemModal
If hideDockForNMinutes = True Then
hideDockForNMinutes = False
Call dock.ShowDockNow
Else
Call dock.HideDockNow
End If
End If
If nCode < 0 Then CallBackHook = CallNextHookEx(lHookID, nCode, wParam, ByVal lParam)
On Error GoTo 0
Exit Function
CallBackHook_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CallBackHook of Module mdlhotkeys"
End Function
' .01 mdlhotkeys.bas DAEB 27/01/2021 Added the hotkeys module to support system wide keypresses
'---------------------------------------------------------------------------------------
' Procedure : SetHotKey
' Author : beededea
' Date : 28/01/2021
' Purpose :
'---------------------------------------------------------------------------------------
'
Public Function SetHotKey(ByVal lSpecial As Long, ByVal lKey As Long) As Long
Static lHotKeyID As Long
On Error GoTo SetHotKey_Error
lHotKeyID = lHotKeyID + 1
If RegisterHotKey(0&, lHotKeyID, lSpecial, lKey) <> 0 Then
lHotKeys = lHotKeys + 1
SetHotKey = lHotKeyID
If lHookID = 0 Then lHookID = SetWindowsHookEx(WH_GETMESSAGE, AddressOf CallBackHook, App.hInstance, App.ThreadID)
End If
On Error GoTo 0
Exit Function
SetHotKey_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SetHotKey of Module mdlhotkeys"
End Function
' .01 mdlhotkeys.bas DAEB 27/01/2021 Added the hotkeys module to support system wide keypresses
'---------------------------------------------------------------------------------------
' Procedure : RemoveHotKey
' Author : beededea
' Date : 28/01/2021
' Purpose :
'---------------------------------------------------------------------------------------
'
Public Sub RemoveHotKey(ByVal lHotKeyID As Long)
On Error GoTo RemoveHotKey_Error
If UnregisterHotKey(0&, lHotKeyID) Then
If lHotKeys > 0 Then lHotKeys = lHotKeys - 1
End If
If lHotKeys = 0 And lHookID <> 0 Then
Call UnhookWindowsHookEx(lHookID)
lHookID = 0
End If
On Error GoTo 0
Exit Sub
RemoveHotKey_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure RemoveHotKey of Module mdlhotkeys"
End Sub