GFKeyHook/GFKeyHookmod.bas

Attribute VB_Name = "GFKeyHookmod"
Option Explicit
'(c)2001 by Louis. Use to set up an application‑wide (non‑global) key hook to allow a target project to use hot keys.
'
'Interface sub (copy to target form):
'Public Sub GFKeyHookProc(ByVal SourceDescription As String, ByVal KeyCode As Integer, ByVal Shift As Integer, ByRef ReturnValueUsedFlag As Boolean, ByRef ReturnValue As Long)
'    'on error resume next
'End Sub
'
'NOTE: the target project must define and process hot keys.
'Also informing the user about hot keys is the task of the target project.
'It is recommended to use a sub called 'DefineHotKeys' for defining
'the hot keys at program start up.
'
'GFKeyHook_SetKeyHook
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
'GFKeyHook_Terminate
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
'KeyHookProc
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
'GFKeyHook_SetKeyHook
Private Const WH_KEYBOARD = 2
'KeyHookProc
Private Const HC_ACTION = 0
'GFKeyHookStruct
Private Type GFKeyHookStruct
    KeyHookEnabledFlag As Boolean
    KeyHookTargetFormName As String
    KeyHookTargetForm As Object
End Type
Dim GFKeyHookStructNumber As Integer
Dim GFKeyHookStructArray() As GFKeyHookStruct
'other
Dim KeyHookEnabledFlag As Boolean 'if key hook has been set up once
Dim KeyHookHandle As Long

Public Sub GFKeyHook_SetKeyHook(ByVal KeyHookTargetFormName As String, ByRef KeyHookTargetForm As Object)
    'On Error Resume Next 'add another form to the KeyHook target form buffer
    Dim StructIndex As Integer
    Dim StructLoop As Integer
    '
    'NOTE: call this sub to set a form into the 'key hook event notification queue'.
    'Call [...]_RemoveKeyHook to remove the form again.
    'The key hook itself will not be removed until GFKeyHook_Terminate is called.
    '
    'preset
    StructIndex = 0 'reset (error)
    For StructLoop = 1 To GFKeyHookStructNumber
        If GFKeyHookStructArray(StructLoop).KeyHookTargetFormName = KeyHookTargetFormName Then
            StructIndex = StructLoop
            Exit For
        End If
    Next StructLoop
    'begin
    If StructIndex = 0 Then
        'create new array element to add target form
        If Not (GFKeyHookStructNumber = 32766) Then 'verify
            GFKeyHookStructNumber = GFKeyHookStructNumber + 1
        Else
            MsgBox "internal error in GFKeyHook_SetKeyHook(): overflow !", vbOKOnly + vbExclamation 'damn it!
            Exit Sub 'error
        End If
        ReDim Preserve GFKeyHookStructArray(1 To GFKeyHookStructNumber) As GFKeyHookStruct
        GFKeyHookStructArray(GFKeyHookStructNumber).KeyHookEnabledFlag = True
        GFKeyHookStructArray(GFKeyHookStructNumber).KeyHookTargetFormName = KeyHookTargetFormName
        Set GFKeyHookStructArray(GFKeyHookStructNumber).KeyHookTargetForm = KeyHookTargetForm
        'enable key hook if not done yet
        If KeyHookEnabledFlag = False Then
            KeyHookEnabledFlag = True
            KeyHookHandle = SetWindowsHookEx(WH_KEYBOARD, AddressOf KeyHookProc, App.hInstance, App.ThreadID) 'use 0 instead of App.ThreadID to set up a global key hook (does not work in VB 5)
        End If
    Else
        'add target form
        GFKeyHookStructArray(GFKeyHookStructNumber).KeyHookEnabledFlag = True
        GFKeyHookStructArray(GFKeyHookStructNumber).KeyHookTargetFormName = KeyHookTargetFormName 'useless
        Set GFKeyHookStructArray(GFKeyHookStructNumber).KeyHookTargetForm = KeyHookTargetForm
    End If
    Exit Sub
End Sub

Public Sub GFKeyHook_RemoveKeyHook(ByVal KeyHookTargetFormName As String, ByRef KeyHookTargetForm As Object)
    'On Error Resume Next 'call to prevent a target form from receiving messages (call [...]_SetKeyHook() to enable message receiving again)
    Dim StructIndex As Integer
    Dim StructLoop As Integer
    'preset
    StructIndex = 0 'reset (error)
    For StructLoop = 1 To GFKeyHookStructNumber
        If GFKeyHookStructArray(StructLoop).KeyHookTargetFormName = KeyHookTargetFormName Then
            StructIndex = StructLoop
            Exit For
        End If
    Next StructLoop
    'begin
    If Not (StructIndex = 0) Then 'verify
        GFKeyHookStructArray(StructIndex).KeyHookEnabledFlag = False
    End If
End Sub

Public Sub GFKeyHook_Terminate()
    'On Error Resume Next 'call when unloading target project
    If KeyHookEnabledFlag = True Then
        KeyHookEnabledFlag = False 'reset
        Call UnhookWindowsHookEx(KeyHookHandle)
    End If
End Sub

Public Function KeyHookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    'On Error Resume Next 'code mainly copied from NN99
    Dim ReturnValueUsedFlag As Boolean
    Dim ReturnValue As Long
    Dim Shift As Integer
    Dim StructLoop As Integer
    'begin
    If nCode = HC_ACTION Then
        If (GetAsyncKeyState(20) And 1) Then 'check if CapsLock is pressed
            Shift = Shift + vbShiftMask
        Else
            If GetAsyncKeyState(16) Then
                Shift = Shift + vbShiftMask
            End If
        End If
        If GetAsyncKeyState(17) Then
            Shift = Shift + vbCtrlMask
        End If
        If GetAsyncKeyState(18) Then
            Shift = Shift + vbAltMask
        End If
        If Not ((GetAsyncKeyState(wParam) And &H8001) = 0) Then 'check for keydown event
            For StructLoop = 1 To GFKeyHookStructNumber
                Call GFKeyHookStructArray(StructLoop).KeyHookTargetForm.GFKeyHookProc( _
                    GFKeyHookStructArray(StructLoop).KeyHookTargetFormName, CInt(wParam), Shift, ReturnValueUsedFlag, ReturnValue)
            Next StructLoop
        End If
    End If
    If ReturnValueUsedFlag = False Then
        KeyHookProc = CallNextHookEx(KeyHookHandle, nCode, wParam, lParam)
    Else
        KeyHookProc = ReturnValue
    End If
End Function

'***END OF MODULE***


[END OF FILE]