WindowsHookInstaller

WindowsHookInstaller.vb

Imports System.ComponentModel
Imports System.Runtime.InteropServices

''' <summary>
''' Class that install hook procedures using SetWindowsHookEx
''' </summary>
<DesignerCategory("Code")>
Public MustInherit Class WindowsHookInstaller
    Inherits Component

    Protected HookType As WindowsHook
    Private HookHandle As IntPtr = IntPtr.Zero
    Private CallBackHandle As CallBackDelegate

    Protected Sub New(hookType As WindowsHook)
        Me.HookType = hookType
    End Sub

    Protected Sub New(hookType As WindowsHook, container As IContainer)
        Me.New(hookType)
        If container Is Nothing Then
            Throw New ArgumentNullException("container")
        End If
        container.Add(Me)
    End Sub

    Public Sub Start()
        Dim appInstance As IntPtr
        Dim threadId As Integer
        Select Case HookType
            Case WindowsHook.WH_KEYBOARD_LL,
                 WindowsHook.WH_MOUSE_LL
                ' Global Hook
                appInstance = GetModuleHandle(Nothing)
                threadId = 0
            Case Else
                ' Thread Hook
                appInstance = IntPtr.Zero
                threadId = GetCurrentThreadId()
        End Select
        If HookHandle = IntPtr.Zero Then
            CallBackHandle = AddressOf CallBackProc
            HookHandle = SetWindowsHookEx(HookType,
                                          CallBackHandle,
                                          appInstance,
                                          threadId)
        End If
    End Sub

    Public Sub [Stop]()
        If HookHandle <> IntPtr.Zero Then
            UnhookWindowsHookEx(HookHandle)
            CallBackHandle = Nothing
            HookHandle = IntPtr.Zero
        End If
    End Sub

    Protected Overrides Sub Dispose(disposing As Boolean)
        MyBase.Dispose(disposing)
        Me.Stop()
    End Sub

    Private Function CallBackProc(
                nCode As HookCode, wParam As IntPtr, lParam As IntPtr) As IntPtr
        Dim hm As New HookMessage With {
            .Code = nCode,
            .WParam = wParam,
            .LParam = lParam
        }
        HookProc(hm)
        Return hm.Result
    End Function

    Protected Overridable Sub HookProc(ByRef hm As HookMessage)
        hm.Result = CallNextHookEx(HookHandle, hm.Code, hm.WParam, hm.LParam)
    End Sub

    Protected Structure HookMessage
        Public Property Code As HookCode
        Public Property WParam As IntPtr
        Public Property LParam As IntPtr
        Public Property Result As IntPtr
    End Structure

    Protected Enum WindowsHook
        WH_JOURNALRECORD = 0
        WH_JOURNALPLAYBACK = 1
        WH_KEYBOARD = 2
        WH_GETMESSAGE = 3
        WH_CALLWNDPROC = 4
        WH_CBT = 5
        WH_SYSMSGFILTER = 6
        WH_MOUSE = 7
        WH_HARDWARE = 8
        WH_DEBUG = 9
        WH_SHELL = 10
        WH_FOREGROUNDIDLE = 11
        WH_CALLWNDPROCRET = 12
        WH_KEYBOARD_LL = 13
        WH_MOUSE_LL = 14
    End Enum

    Protected Enum HookCode
        HC_ACTION = 0
        HC_GETNEXT = 1
        HC_SKIP = 2
        HC_NOREMOVE = 3
        HC_NOREM = HC_NOREMOVE
        HC_SYSMODALON = 4
        HC_SYSMODALOFF = 5
    End Enum

    Private Const User32 = "user32.dll"
    Private Const Kernel32 = "kernel32.dll"

    Private Delegate Function CallBackDelegate(
            nCode As HookCode, wParam As IntPtr, lParam As IntPtr) As IntPtr

    <StructLayout(LayoutKind.Sequential)>
    Private Structure KBDLLHOOKSTRUCT
        Public vkCode As Keys
        Public scanCode As Keys
        Public flags As Integer
        Public time As Integer
        Public dwExtraInfo As IntPtr
    End Structure

    <DllImport(User32, CharSet:=CharSet.Auto)>
    Private Shared Function SetWindowsHookEx(
                    idHook As WindowsHook, lpfn As CallBackDelegate,
                    hInstance As IntPtr, threadId As Integer) As IntPtr
    End Function

    <DllImport(User32, CharSet:=CharSet.Auto)>
    Private Shared Function UnhookWindowsHookEx(hhk As IntPtr) _
                    As <MarshalAs(UnmanagedType.Bool)> Boolean
    End Function

    <DllImport(User32, CharSet:=CharSet.Auto)>
    Private Shared Function CallNextHookEx(
                            idHook As IntPtr, code As Integer,
                            wParam As IntPtr, lparam As IntPtr) As IntPtr
    End Function

    <DllImport(Kernel32, CharSet:=CharSet.Auto)>
    Private Shared Function GetModuleHandle(lpModuleName As String) As IntPtr
    End Function

    <DllImport(Kernel32, CharSet:=CharSet.Auto)>
    Private Shared Function GetCurrentThreadId() As Integer
    End Function

    Protected Shared Function SignedHIWORD(n As IntPtr) As Integer
        Dim tmp As Byte() = BitConverter.GetBytes(n.ToInt64())
        Return SignedHIWORD(BitConverter.ToInt32(tmp, 0))
    End Function

    Protected Shared Function SignedHIWORD(n As Integer) As Integer
        Dim tmp As Byte() = BitConverter.GetBytes(n >> 16 And &HFFFF)
        Return BitConverter.ToInt16(tmp, 0)
    End Function

    Protected Shared Function SignedLOWORD(n As IntPtr) As Integer
        Dim tmp As Byte() = BitConverter.GetBytes(n.ToInt64())
        Return SignedLOWORD(BitConverter.ToInt32(tmp, 0))
    End Function

    Protected Shared Function SignedLOWORD(n As Integer) As Integer
        Dim tmp As Byte() = BitConverter.GetBytes(n And &HFFFF)
        Return BitConverter.ToInt16(tmp, 0)
    End Function

End Class

''' <summary>
''' LowLevelKeyboardHook
''' </summary>
<DefaultEvent("KeyDown")>
Public Class LowLevelKeyboardHook
    Inherits WindowsHookInstaller

    Public Event KeyDown As KeyEventHandler
    Public Event KeyUp As KeyEventHandler

    Public Sub New()
        MyBase.New(WindowsHook.WH_KEYBOARD_LL)
    End Sub

    Public Sub New(container As IContainer)
        MyBase.New(WindowsHook.WH_KEYBOARD_LL, container)
    End Sub

    Protected Overrides Sub HookProc(ByRef hm As HookMessage)
        If hm.Code = HookCode.HC_ACTION Then
            Dim st = Marshal.PtrToStructure(Of KBDLLHOOKSTRUCT)(hm.LParam)
            Dim vkCode As Keys = st.vkCode Or Control.ModifierKeys
            Dim ke = New KeyEventArgsEx(vkCode)
            Select Case hm.WParam.ToInt64()
                Case WM_KEYDOWN
                    OnKeyDown(ke)
                Case WM_KEYUP
                    OnKeyUp(ke)
            End Select
        End If
        MyBase.HookProc(hm)
    End Sub

    Protected Overridable Sub OnKeyDown(ke As KeyEventArgs)
        RaiseEvent KeyDown(Me, ke)
    End Sub

    Protected Overridable Sub OnKeyUp(ke As KeyEventArgs)
        RaiseEvent KeyUp(Me, ke)
    End Sub

    Private Class KeyEventArgsEx
        Inherits KeyEventArgs

        Public Sub New(vkCode As Keys)
            MyBase.New(vkCode)
        End Sub

        Public Overrides Function ToString() As String
            Return $"(KeyCode={KeyCode},KeyData={KeyData},KeyValue={KeyValue}," &
                   $"Control={Control},Shift={Shift},Alt={Alt})"
        End Function
    End Class

    Private Const WM_KEYDOWN = &H100
    Private Const WM_KEYUP = &H101

    <StructLayout(LayoutKind.Sequential)>
    Private Structure KBDLLHOOKSTRUCT
        Public vkCode As Keys
        Public scanCode As Keys
        Public flags As Integer
        Public time As Integer
        Public dwExtraInfo As IntPtr
    End Structure

End Class

''' <summary>
''' LowLevelMouseHook
''' </summary>
<DefaultEvent("MouseDown")>
Public Class LowLevelMouseHook
    Inherits WindowsHookInstaller

    Public Sub New()
        MyBase.New(WindowsHook.WH_MOUSE_LL)
    End Sub

    Public Sub New(container As IContainer)
        MyBase.New(WindowsHook.WH_MOUSE_LL, container)
    End Sub

    Public Event MouseDown As MouseEventHandler
    Public Event MouseUp As MouseEventHandler
    Public Event MouseDoubleClick As MouseEventHandler
    Public Event MouseMove As MouseEventHandler
    Public Event MouseWheel As MouseEventHandler

    Protected Overridable Sub OnMouseDown(e As MouseEventArgs)
        If CanRaiseEvents Then RaiseEvent MouseDown(Me, e)
    End Sub

    Protected Overridable Sub OnMouseUp(e As MouseEventArgs)
        If CanRaiseEvents Then RaiseEvent MouseUp(Me, e)
    End Sub

    Protected Overridable Sub OnMouseDoubleClick(e As MouseEventArgs)
        If CanRaiseEvents Then RaiseEvent MouseDoubleClick(Me, e)
    End Sub

    Protected Overridable Sub OnMouseMove(e As MouseEventArgs)
        If CanRaiseEvents Then RaiseEvent MouseMove(Me, e)
    End Sub

    Protected Overridable Sub OnMouseWheel(e As MouseEventArgs)
        If CanRaiseEvents Then RaiseEvent MouseWheel(Me, e)
    End Sub

    Protected Overrides Sub HookProc(ByRef hm As HookMessage)
        If hm.Code = HookCode.HC_ACTION Then
            Dim st = Marshal.PtrToStructure(Of MSLLHOOKSTRUCT)(hm.LParam)
            Dim msg As Integer = hm.WParam.ToInt32()
            Dim e = CreateMouseEventArgs(msg, st)
            Select Case msg
                Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN, WM_XBUTTONDOWN, WM_NCXBUTTONDOWN
                    OnMouseDown(e)
                Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP, WM_XBUTTONUP, WM_NCXBUTTONUP
                    OnMouseUp(e)
                Case WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK, WM_MBUTTONDBLCLK, WM_XBUTTONDBLCLK, WM_NCXBUTTONDBLCLK
                    OnMouseDoubleClick(e)
                Case WM_MOUSEMOVE
                    OnMouseMove(e)
                Case WM_MOUSEWHEEL
                    OnMouseWheel(e)
            End Select
        End If
        MyBase.HookProc(hm)
    End Sub

    Private Function CreateMouseEventArgs(msg As Integer,
                                          ByRef st As MSLLHOOKSTRUCT) As MouseEventArgs
        Dim button As MouseButtons = MouseButtons.None
        Dim delta As Integer = SignedHIWORD(st.mouseData)
        Select Case msg
            Case WM_LBUTTONDOWN, WM_LBUTTONUP, WM_LBUTTONDBLCLK
                button = MouseButtons.Left
            Case WM_RBUTTONDOWN, WM_RBUTTONUP, WM_RBUTTONDBLCLK
                button = MouseButtons.Right
            Case WM_MBUTTONDOWN, WM_MBUTTONUP, WM_MBUTTONDBLCLK
                button = MouseButtons.Middle
            Case WM_XBUTTONDOWN, WM_XBUTTONUP, WM_XBUTTONDBLCLK,
                 WM_NCXBUTTONDOWN, WM_NCXBUTTONUP, WM_NCXBUTTONDBLCLK
                Select Case delta
                    Case 1
                        button = MouseButtons.XButton1
                    Case 2
                        button = MouseButtons.XButton2
                End Select
        End Select
        Return New MouseEventArgsEx(button, 0, st.pt.X, st.pt.Y, delta)
    End Function

    Private Class MouseEventArgsEx
        Inherits MouseEventArgs
        Public Sub New(button As MouseButtons, clicks As Integer, x As Integer, y As Integer, delta As Integer)
            MyBase.New(button, clicks, x, y, delta)
        End Sub

        Public Overrides Function ToString() As String
            Return $"(Button={Button},x={X},y={Y},delta={Delta})"
        End Function
    End Class

    Private Const WM_MOUSEFIRST = &H200
    Private Const WM_MOUSEMOVE = &H200
    Private Const WM_LBUTTONDOWN = &H201
    Private Const WM_LBUTTONUP = &H202
    Private Const WM_LBUTTONDBLCLK = &H203
    Private Const WM_RBUTTONDOWN = &H204
    Private Const WM_RBUTTONUP = &H205
    Private Const WM_RBUTTONDBLCLK = &H206
    Private Const WM_MBUTTONDOWN = &H207
    Private Const WM_MBUTTONUP = &H208
    Private Const WM_MBUTTONDBLCLK = &H209
    Private Const WM_XBUTTONDOWN = &H20B
    Private Const WM_XBUTTONUP = &H20C
    Private Const WM_XBUTTONDBLCLK = &H20D
    Private Const WM_MOUSEWHEEL = &H20A
    Private Const WM_MOUSELAST = &H20A

    Private Const WM_NCXBUTTONDOWN = &HAB
    Private Const WM_NCXBUTTONUP = &HAC
    Private Const WM_NCXBUTTONDBLCLK = &HAD

    Private Structure MSLLHOOKSTRUCT
        Public pt As Point
        Public mouseData As Integer
        Public flags As Integer
        Public time As Integer
        Public dwExtraInfo As IntPtr
    End Structure

End Class

HowToUse

Public Class Form2

    Private Sub Form2_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        LowLevelKeyboardHook1.Start()
        LowLevelMouseHook1.Start()
    End Sub

    Private Sub LowLevelKeyboardHook1_KeyDown(sender As Object, e As KeyEventArgs) Handles LowLevelKeyboardHook1.KeyDown
        TextBox1.AppendText(Now & $" KeyDown {e}" & vbCrLf)
    End Sub

    Private Sub LowLevelKeyboardHook1_KeyUp(sender As Object, e As KeyEventArgs) Handles LowLevelKeyboardHook1.KeyUp
        TextBox1.AppendText(Now & $" KeyUp {e}" & vbCrLf)
    End Sub

    Private Sub LowLevelMouseHook1_MouseDown(sender As Object, e As MouseEventArgs) Handles LowLevelMouseHook1.MouseDown
        TextBox1.AppendText(Now & $" MouseDown {e}" & vbCrLf)
    End Sub

    Private Sub LowLevelMouseHook1_MouseUp(sender As Object, e As MouseEventArgs) Handles LowLevelMouseHook1.MouseUp
        TextBox1.AppendText(Now & $" MouseUp {e}" & vbCrLf)
    End Sub

    Private Sub LowLevelMouseHook1_MouseDoubleClick(sender As Object, e As MouseEventArgs) Handles LowLevelMouseHook1.MouseDoubleClick
        TextBox1.AppendText(Now & $" MouseDoubleClick {e}" & vbCrLf)
    End Sub

    Private Sub LowLevelMouseHook1_MouseMove(sender As Object, e As MouseEventArgs) Handles LowLevelMouseHook1.MouseMove
        TextBox1.AppendText(Now & $" MouseMove {e}" & vbCrLf)
    End Sub

    Private Sub LowLevelMouseHook1_MouseWheel(sender As Object, e As MouseEventArgs) Handles LowLevelMouseHook1.MouseWheel
        TextBox1.AppendText(Now & $" MouseWheel {e}" & vbCrLf)
    End Sub

End Class