Visual Basic全局鍵盤掛勾(keyboard hook)VB.NET

Visual Basic全局滑鼠掛勾(mouse hook)VB.NET
請使用Ctrl+F5編譯程式
掛勾:

Imports System.Reflection, System.Threading, System.ComponentModel, System.Runtime.InteropServices

Public Class SystemHook

#Region "定義結構"
    Private Structure KeyboardHookStruct
        Dim vkCode As Integer
        Dim ScanCode As Integer
        Dim Flags As Integer
        Dim Time As Integer
        Dim DwExtraInfo As Integer
    End Structure
#End Region

#Region "API聲明導入"
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Integer, ByVal lpfn As HookProc, ByVal hMod As IntPtr, ByVal dwThreadId As Integer) As Integer
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal idHook As Integer) As Integer
    Private Declare Function CallNextHookEx Lib "user32" (ByVal idHook As Integer, ByVal nCode As Integer, ByVal wParam As Integer, ByVal lParam As IntPtr) As Integer
    Private Declare Function ToAscii Lib "user32" (ByVal uVirtKey As Integer, ByVal uScancode As Integer, ByVal lpdKeyState As Byte(), ByVal lpwTransKey As Byte(), ByVal fuState As Integer) As Integer
    Private Declare Function GetKeyboardState Lib "user32" (ByVal pbKeyState As Byte()) As Integer
    Private Declare Function GetKeyState Lib "user32" (ByVal vKey As Integer) As Short
    Private Delegate Function HookProc(ByVal nCode As Integer, ByVal wParam As Integer, ByVal lParam As IntPtr) As Integer
#End Region

#Region "常量聲明"
    Private Const WH_KEYBOARD_LL = 13
    Private Const WM_KEYDOWN = &H100
    Private Const WM_KEYUP = &H101
    Private Const WM_SYSKEYDOWN = &H104
    Private Const WM_SYSKEYUP = &H105
    Private Const VK_SHIFT As Byte = &H10
    Private Const VK_CAPITAL As Byte = &H14
#End Region

#Region "事件委託處理"
    Private events As New System.ComponentModel.EventHandlerList

    ''' 
鍵盤按下事件
    Public Custom Event KeyDown As KeyEventHandler
        AddHandler(ByVal value As KeyEventHandler)
            events.AddHandler("KeyDown", value)
        End AddHandler
        RemoveHandler(ByVal value As KeyEventHandler)
            events.RemoveHandler("KeyDown", value)
        End RemoveHandler
        RaiseEvent(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs)
            Dim eh As KeyEventHandler = TryCast(events("KeyDown"), KeyEventHandler)
            If eh IsNot Nothing Then eh.Invoke(sender, e)
        End RaiseEvent
    End Event
    ''' 
鍵盤輸入事件
    Public Custom Event KeyPress As KeyPressEventHandler
        AddHandler(ByVal value As KeyPressEventHandler)
            events.AddHandler("KeyPress", value)
        End AddHandler
        RemoveHandler(ByVal value As KeyPressEventHandler)
            events.RemoveHandler("KeyPress", value)
        End RemoveHandler
        RaiseEvent(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyPressEventArgs)
            Dim eh As KeyPressEventHandler = TryCast(events("KeyPress"), KeyPressEventHandler)
            If eh IsNot Nothing Then eh.Invoke(sender, e)
        End RaiseEvent
    End Event
    ''' 
鍵盤鬆開事件
    Public Custom Event KeyUp As KeyEventHandler
        AddHandler(ByVal value As KeyEventHandler)
            events.AddHandler("KeyUp", value)
        End AddHandler
        RemoveHandler(ByVal value As KeyEventHandler)
            events.RemoveHandler("KeyUp", value)
        End RemoveHandler
        RaiseEvent(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs)
            Dim eh As KeyEventHandler = TryCast(events("KeyUp"), KeyEventHandler)
            If eh IsNot Nothing Then eh.Invoke(sender, e)
        End RaiseEvent
    End Event
#End Region

    Private hKeyboardHook As Integer
    Private Shared KeyboardHookProcedure As HookProc

#Region "創建與析構類型"
    ''' 
創建一個全局鼠標鍵盤鉤子 (請使用Start方法開始監視)
    Sub New()
        '留空即可
    End Sub
    ''' 
創建一個全局鼠標鍵盤鉤子，決定是否安裝鉤子
    ''' 是否立刻掛鉤系統消息
    Sub New(ByVal InstallAll As Boolean)
        If InstallAll Then StartHook(True)
    End Sub
    ''' 
析構函數
    Protected Overrides Sub Finalize()
        UnHook() '卸載對象時反註冊系統鉤子
        MyBase.Finalize()
    End Sub

#End Region

    ''' 
開始安裝系統鉤子
    ''' 掛鉤鍵盤消息
    Public Sub StartHook(Optional ByVal InstallKeyboardHook As Boolean = True)
        '註冊鍵盤鉤子
        If InstallKeyboardHook AndAlso hKeyboardHook = 0 Then
            KeyboardHookProcedure = New HookProc(AddressOf KeyboardHookProc)
            hKeyboardHook = SetWindowsHookEx(WH_KEYBOARD_LL, KeyboardHookProcedure, Marshal.GetHINSTANCE(Assembly.GetExecutingAssembly.GetModules()(0)), 0)
            If hKeyboardHook = 0 Then '檢測是否註冊完成
                UnHook(True, False) '在這裡反註冊
                Throw New Win32Exception(Marshal.GetLastWin32Error) '報告錯誤
            End If
        End If
    End Sub
    ''' 
立刻卸載系統鉤子
    ''' 卸載鍵盤鉤子
    ''' 是否報告錯誤
    Public Sub UnHook(Optional ByVal UninstallKeyboardHook As Boolean = True, Optional ByVal ThrowExceptions As Boolean = False)
        '卸載鍵盤鉤子
        If hKeyboardHook <> 0 AndAlso UninstallKeyboardHook Then
            Dim retKeyboard As Integer = UnhookWindowsHookEx(hKeyboardHook)
            hKeyboardHook = 0
            If ThrowExceptions AndAlso retKeyboard = 0 Then '如果出現錯誤，是否報告錯誤
                Throw New Win32Exception(Marshal.GetLastWin32Error) '報告錯誤
            End If
        End If
    End Sub

    '鍵盤消息的委託處理代碼
    Private Function KeyboardHookProc(ByVal nCode As Integer, ByVal wParam As Integer, ByVal lParam As IntPtr) As Integer
        Static handled As Boolean : handled = False
        If nCode >= 0 AndAlso (events("KeyDown") IsNot Nothing OrElse events("KeyPress") IsNot Nothing OrElse events("KeyUp") IsNot Nothing) Then
            Static MyKeyboardHookStruct As KeyboardHookStruct
            MyKeyboardHookStruct = DirectCast(Marshal.PtrToStructure(lParam, GetType(KeyboardHookStruct)), KeyboardHookStruct)
            '激活KeyDown
            If wParam = WM_KEYDOWN OrElse wParam = WM_SYSKEYDOWN Then '如果消息為按下普通鍵或系統鍵
                Dim e As New KeyEventArgs(MyKeyboardHookStruct.vkCode)
                RaiseEvent KeyDown(Me, e) '激活事件
                handled = handled Or e.Handled '是否取消下一個鉤子
            End If
            '激活KeyUp
            If wParam = WM_KEYUP OrElse wParam = WM_SYSKEYUP Then
                Dim e As New KeyEventArgs(MyKeyboardHookStruct.vkCode)
                RaiseEvent KeyUp(Me, e)
                handled = handled Or e.Handled
            End If
            '激活KeyPress
            If wParam = WM_KEYDOWN Then
                Dim isDownShift As Boolean = (GetKeyState(VK_SHIFT) & &H80 = &H80)
                Dim isDownCapslock As Boolean = (GetKeyState(VK_CAPITAL) <> 0)
                Dim keyState(256) As Byte
                GetKeyboardState(keyState)
                Dim inBuffer(2) As Byte
                If ToAscii(MyKeyboardHookStruct.vkCode, MyKeyboardHookStruct.ScanCode, keyState, inBuffer, MyKeyboardHookStruct.Flags) = 1 Then
                    Static key As Char : key = Chr(inBuffer(0))
                    Dim e As New KeyPressEventArgs(key)
                    RaiseEvent KeyPress(Me, e)
                    handled = handled Or e.Handled
                End If
            End If
            '取消或者激活下一個鉤子
            If handled Then Return 1 Else Return CallNextHookEx(hKeyboardHook, nCode, wParam, lParam)
        Else
            Static none As HookProc
            Return none(nCode, wParam, lParam)
        End If
    End Function

    ''' 
鍵盤鉤子是否有效
    Public Property KeyHookEnabled() As Boolean
        Get
            Return hKeyboardHook <> 0
        End Get
        Set(ByVal value As Boolean)
            If value Then StartHook(True) Else UnHook(True, False)
        End Set
    End Property
End Class

實例示範(影片/程式):

Imports System.Reflection, System.Threading, System.ComponentModel, System.Runtime.InteropServices
Public Class Form1
    Dim WithEvents MyHook As New SystemHook()
    Private Sub MyHook_KeyPress(sender As Object, e As KeyPressEventArgs) Handles MyHook.KeyPress
        Lab_KeyPress.Text = e.KeyChar
    End Sub
    Private Sub MyHook_KeyDown(sender As Object, e As KeyEventArgs) Handles MyHook.KeyDown
        Lab_KeyDown.Text = e.KeyCode & " " & Chr(e.KeyCode)
    End Sub
    Private Sub MyHook_KeyUp(sender As Object, e As KeyEventArgs) Handles MyHook.KeyUp
        Lab_KeyUp.Text = e.KeyCode & " " & Chr(e.KeyCode)
    End Sub
    Private Sub Form1_Closing(sender As Object, e As CancelEventArgs) Handles Me.Closing
        MyHook.UnHook()
    End Sub
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load
        MyHook.StartHook()
    End Sub
End Class


Public Class SystemHook

#Region "定義結構"
    Private Structure KeyboardHookStruct
        Dim vkCode As Integer
        Dim ScanCode As Integer
        Dim Flags As Integer
        Dim Time As Integer
        Dim DwExtraInfo As Integer
    End Structure
#End Region

#Region "API聲明導入"
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Integer, ByVal lpfn As HookProc, ByVal hMod As IntPtr, ByVal dwThreadId As Integer) As Integer
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal idHook As Integer) As Integer
    Private Declare Function CallNextHookEx Lib "user32" (ByVal idHook As Integer, ByVal nCode As Integer, ByVal wParam As Integer, ByVal lParam As IntPtr) As Integer
    Private Declare Function ToAscii Lib "user32" (ByVal uVirtKey As Integer, ByVal uScancode As Integer, ByVal lpdKeyState As Byte(), ByVal lpwTransKey As Byte(), ByVal fuState As Integer) As Integer
    Private Declare Function GetKeyboardState Lib "user32" (ByVal pbKeyState As Byte()) As Integer
    Private Declare Function GetKeyState Lib "user32" (ByVal vKey As Integer) As Short
    Private Delegate Function HookProc(ByVal nCode As Integer, ByVal wParam As Integer, ByVal lParam As IntPtr) As Integer
#End Region

#Region "常量聲明"
    Private Const WH_KEYBOARD_LL = 13
    Private Const WM_KEYDOWN = &H100
    Private Const WM_KEYUP = &H101
    Private Const WM_SYSKEYDOWN = &H104
    Private Const WM_SYSKEYUP = &H105
    Private Const VK_SHIFT As Byte = &H10
    Private Const VK_CAPITAL As Byte = &H14
#End Region

#Region "事件委託處理"
    Private events As New System.ComponentModel.EventHandlerList

    ''' 
鍵盤按下事件
    Public Custom Event KeyDown As KeyEventHandler
        AddHandler(ByVal value As KeyEventHandler)
            events.AddHandler("KeyDown", value)
        End AddHandler
        RemoveHandler(ByVal value As KeyEventHandler)
            events.RemoveHandler("KeyDown", value)
        End RemoveHandler
        RaiseEvent(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs)
            Dim eh As KeyEventHandler = TryCast(events("KeyDown"), KeyEventHandler)
            If eh IsNot Nothing Then eh.Invoke(sender, e)
        End RaiseEvent
    End Event
    ''' 
鍵盤輸入事件
    Public Custom Event KeyPress As KeyPressEventHandler
        AddHandler(ByVal value As KeyPressEventHandler)
            events.AddHandler("KeyPress", value)
        End AddHandler
        RemoveHandler(ByVal value As KeyPressEventHandler)
            events.RemoveHandler("KeyPress", value)
        End RemoveHandler
        RaiseEvent(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyPressEventArgs)
            Dim eh As KeyPressEventHandler = TryCast(events("KeyPress"), KeyPressEventHandler)
            If eh IsNot Nothing Then eh.Invoke(sender, e)
        End RaiseEvent
    End Event
    ''' 
鍵盤鬆開事件
    Public Custom Event KeyUp As KeyEventHandler
        AddHandler(ByVal value As KeyEventHandler)
            events.AddHandler("KeyUp", value)
        End AddHandler
        RemoveHandler(ByVal value As KeyEventHandler)
            events.RemoveHandler("KeyUp", value)
        End RemoveHandler
        RaiseEvent(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs)
            Dim eh As KeyEventHandler = TryCast(events("KeyUp"), KeyEventHandler)
            If eh IsNot Nothing Then eh.Invoke(sender, e)
        End RaiseEvent
    End Event
#End Region

    Private hKeyboardHook As Integer
    Private Shared KeyboardHookProcedure As HookProc

#Region "創建與析構類型"
    ''' 
創建一個全局鼠標鍵盤鉤子 (請使用Start方法開始監視)
    Sub New()
        '留空即可
    End Sub
    ''' 
創建一個全局鼠標鍵盤鉤子，決定是否安裝鉤子
    ''' 是否立刻掛鉤系統消息
    Sub New(ByVal InstallAll As Boolean)
        If InstallAll Then StartHook(True)
    End Sub
    ''' 
析構函數
    Protected Overrides Sub Finalize()
        UnHook() '卸載對象時反註冊系統鉤子
        MyBase.Finalize()
    End Sub

#End Region

    ''' 
開始安裝系統鉤子
    ''' 掛鉤鍵盤消息
    Public Sub StartHook(Optional ByVal InstallKeyboardHook As Boolean = True)
        '註冊鍵盤鉤子
        If InstallKeyboardHook AndAlso hKeyboardHook = 0 Then
            KeyboardHookProcedure = New HookProc(AddressOf KeyboardHookProc)
            hKeyboardHook = SetWindowsHookEx(WH_KEYBOARD_LL, KeyboardHookProcedure, Marshal.GetHINSTANCE(Assembly.GetExecutingAssembly.GetModules()(0)), 0)
            If hKeyboardHook = 0 Then '檢測是否註冊完成
                UnHook(True, False) '在這裡反註冊
                Throw New Win32Exception(Marshal.GetLastWin32Error) '報告錯誤
            End If
        End If
    End Sub
    ''' 
立刻卸載系統鉤子
    ''' 卸載鍵盤鉤子
    ''' 是否報告錯誤
    Public Sub UnHook(Optional ByVal UninstallKeyboardHook As Boolean = True, Optional ByVal ThrowExceptions As Boolean = False)
        '卸載鍵盤鉤子
        If hKeyboardHook <> 0 AndAlso UninstallKeyboardHook Then
            Dim retKeyboard As Integer = UnhookWindowsHookEx(hKeyboardHook)
            hKeyboardHook = 0
            If ThrowExceptions AndAlso retKeyboard = 0 Then '如果出現錯誤，是否報告錯誤
                Throw New Win32Exception(Marshal.GetLastWin32Error) '報告錯誤
            End If
        End If
    End Sub

    '鍵盤消息的委託處理代碼
    Private Function KeyboardHookProc(ByVal nCode As Integer, ByVal wParam As Integer, ByVal lParam As IntPtr) As Integer
        Static handled As Boolean : handled = False
        If nCode >= 0 AndAlso (events("KeyDown") IsNot Nothing OrElse events("KeyPress") IsNot Nothing OrElse events("KeyUp") IsNot Nothing) Then
            Static MyKeyboardHookStruct As KeyboardHookStruct
            MyKeyboardHookStruct = DirectCast(Marshal.PtrToStructure(lParam, GetType(KeyboardHookStruct)), KeyboardHookStruct)
            '激活KeyDown
            If wParam = WM_KEYDOWN OrElse wParam = WM_SYSKEYDOWN Then '如果消息為按下普通鍵或系統鍵
                Dim e As New KeyEventArgs(MyKeyboardHookStruct.vkCode)
                RaiseEvent KeyDown(Me, e) '激活事件
                handled = handled Or e.Handled '是否取消下一個鉤子
            End If
            '激活KeyUp
            If wParam = WM_KEYUP OrElse wParam = WM_SYSKEYUP Then
                Dim e As New KeyEventArgs(MyKeyboardHookStruct.vkCode)
                RaiseEvent KeyUp(Me, e)
                handled = handled Or e.Handled
            End If
            '激活KeyPress
            If wParam = WM_KEYDOWN Then
                Dim isDownShift As Boolean = (GetKeyState(VK_SHIFT) & &H80 = &H80)
                Dim isDownCapslock As Boolean = (GetKeyState(VK_CAPITAL) <> 0)
                Dim keyState(256) As Byte
                GetKeyboardState(keyState)
                Dim inBuffer(2) As Byte
                If ToAscii(MyKeyboardHookStruct.vkCode, MyKeyboardHookStruct.ScanCode, keyState, inBuffer, MyKeyboardHookStruct.Flags) = 1 Then
                    Static key As Char : key = Chr(inBuffer(0))
                    Dim e As New KeyPressEventArgs(key)
                    RaiseEvent KeyPress(Me, e)
                    handled = handled Or e.Handled
                End If
            End If
            '取消或者激活下一個鉤子
            If handled Then Return 1 Else Return CallNextHookEx(hKeyboardHook, nCode, wParam, lParam)
        Else
            Static none As HookProc
            Return none(nCode, wParam, lParam)
        End If
    End Function

    ''' 
鍵盤鉤子是否有效
    Public Property KeyHookEnabled() As Boolean
        Get
            Return hKeyboardHook <> 0
        End Get
        Set(ByVal value As Boolean)
            If value Then StartHook(True) Else UnHook(True, False)
        End Set
    End Property
End Class