程序師世界是廣大編程愛好者互助、分享、學習的平台,程序師世界有你更精彩!
首頁
編程語言
C語言|JAVA編程
Python編程
網頁編程
ASP編程|PHP編程
JSP編程
數據庫知識
MYSQL數據庫|SqlServer數據庫
Oracle數據庫|DB2數據庫
 程式師世界 >> 編程語言 >> Visual Basic語言 >> VB.NET >> VB.NET全局鍵盤鼠標鉤子[Vb.Net Hook](修正版)

VB.NET全局鍵盤鼠標鉤子[Vb.Net Hook](修正版)

編輯:VB.NET

VB.NET全局鍵盤鼠標鉤子[Vb.Net Hook](修正版)。本站提示廣大學習愛好者:(VB.NET全局鍵盤鼠標鉤子[Vb.Net Hook](修正版))文章只能為提供參考,不一定能成為您想要的結果。以下是VB.NET全局鍵盤鼠標鉤子[Vb.Net Hook](修正版)正文


原文有些BUG,由於這是段我從C#直達換而來的代碼,所在最初的轉換中由於兩種言語的性質不同,所以無法完全兼容一些特性。

當然,如今的我曾經完全有才能兼容兩種言語的特性了,所以就重寫了本段代碼,將原代碼中的事情檢測,以及原代碼中的KeyPress 時間無法檢測輸出字符大小寫的BUG消弭(在此感激verywzm 同志) 。

留意:本段代碼假如想要在VS中運轉,請將[工程屬性] - [調試] - [啟動 Visual Studio 宿主進程 ] 設置的勾去掉,或許運用 CTRL+F5 停止編譯後調試!

本段代碼包括風險代碼,請不要用作合法用處!

-------------------------------------------------------------------

這是真正的.NET環境下的全局鍵盤鼠標Hook代碼!

本代碼是我從codeproject中翻來的,原作者Michael Kennedy,C#編碼。

我將該段C#源碼翻譯為了VB代碼,由於這兩種言語的外部機制有一些區別,所以我做了較大的改動。 不容易啊~~

上面的代碼是我修正和擴展後的代碼,保存一切的權益,翻版不究,盜版可恥。

運用辦法很復雜,先新建一個類文件,將代碼復制進取,然後在一個窗體的空白區域添加一個類型實 例。

Dim WithEvents MyHook As New SystemHook()

然後運用靜態綁定事情就可以了。

Hook的一切信息曾經被封裝在了事情的參數中,十分方便哦~

' 十分不容易才翻譯過去的。
' 保存一切權益。

' 夜聞香原創,轉載請保存此信息,萬分感激!
' 博客: http://hi.baidu.com/clso
' 論壇: http://cleclso.cn/
' QQ:315514678 E-mail:[email protected]
' 歡送技術交流!


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

/**/''' <summary>本類可以在.NET環境下運用零碎鍵盤與鼠標鉤子</summary>
Public Class SystemHookClass SystemHook

定義構造#Region "定義構造"

    Private Structure MouseHookStructStructure MouseHookStruct
        Dim PT As POINT
        Dim Hwnd As Integer
        Dim WHitTestCode As Integer
        Dim DwExtraInfo As Integer
    End Structure

    Private Structure MouseLLHookStructStructure MouseLLHookStruct
        Dim PT As POINT
        Dim MouseData As Integer
        Dim Flags As Integer
        Dim Time As Integer
        Dim DwExtraInfo As Integer
    End Structure

    Private Structure KeyboardHookStructStructure 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

API聲明導入#Region "API聲明導入"

    Private Declare Function SetWindowsHookEx()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()Function UnhookWindowsHookEx Lib "user32" (ByVal idHook As Integer) As Integer
    Private Declare Function CallNextHookEx()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()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()Function GetKeyboardState Lib "user32" (ByVal pbKeyState As Byte()) As Integer
    Private Declare Function GetKeyState()Function GetKeyState Lib "user32" (ByVal vKey As Integer) As Short

    Private Delegate Function HookProc()Function HookProc(ByVal nCode As Integer, ByVal wParam As Integer, ByVal lParam As IntPtr) As Integer

#End Region

常量聲明#Region "常量聲明"

    Private Const WH_MOUSE_LL = 14
    Private Const WH_KEYBOARD_LL = 13
    Private Const WH_MOUSE = 7
    Private Const WH_KEYBOARD = 2
    Private Const WM_MOUSEMOVE = &H200
    Private Const WM_LBUTTONDOWN = &H201
    Private Const WM_RBUTTONDOWN = &H204
    Private Const WM_MBUTTONDOWN = &H207
    Private Const WM_LBUTTONUP = &H202
    Private Const WM_RBUTTONUP = &H205
    Private Const WM_MBUTTONUP = &H208
    Private Const WM_LBUTTONDBLCLK = &H203
    Private Const WM_RBUTTONDBLCLK = &H206
    Private Const WM_MBUTTONDBLCLK = &H209
    Private Const WM_MOUSEWHEEL = &H20A
    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
    Private Const VK_NUMLOCK As Byte = &H90

#End Region

事情委托處置#Region "事情委托處置"

    Private events As New System.ComponentModel.EventHandlerList

    /**/''' <summary>鼠標激活事情</summary>
    Public Custom Event MouseActivity As MouseEventHandler
        AddHandler(ByVal value As MouseEventHandler)
            events.AddHandler("MouseActivity", value)
        End AddHandler
        RemoveHandler(ByVal value As MouseEventHandler)
            events.RemoveHandler("MouseActivity", value)
        End RemoveHandler
        RaiseEvent(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs)
            Dim eh As MouseEventHandler = TryCast(events ("MouseActivity"), MouseEventHandler)
            If eh IsNot Nothing Then eh.Invoke(sender, e)
        End RaiseEvent
    End Event
    /**/''' <summary>鍵盤按下事情</summary>
    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
    /**/''' <summary>鍵盤輸出事情</summary>
    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
    /**/''' <summary>鍵盤松開事情</summary>
    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 hMouseHook As Integer
    Private hKeyboardHook As Integer

    Private Shared MouseHookProcedure As HookProc
    Private Shared KeyboardHookProcedure As HookProc

創立與析構類型#Region "創立與析構類型"

    /**/''' <summary>創立一個全局鼠標鍵盤鉤子 (請運用Start辦法開端監視) </summary>
    Sub New()Sub New()
        '留空即可
    End Sub
    /**/''' <summary>創立一個全局鼠標鍵盤鉤子,決議能否裝置鉤子</summary>
    ''' <param name="InstallAll">能否立即掛鉤零碎音訊</param>
    Sub New()Sub New(ByVal InstallAll As Boolean)
        If InstallAll Then StartHook(True, True)
    End Sub
    /**/''' <summary>創立一個全局鼠標鍵盤鉤子,並決議裝置鉤子的類型 </summary>
    ''' <param name="InstallKeyboard">掛鉤鍵盤音訊</param>
    ''' <param name="InstallMouse">掛鉤鼠標音訊</param>
    Sub New()Sub New(ByVal InstallKeyboard As Boolean, ByVal InstallMouse As Boolean)
        StartHook(InstallKeyboard, InstallMouse)
    End Sub
    /**/''' <summary>析構函數</summary>
    Protected Overrides Sub Finalize()Sub Finalize()
        UnHook() '卸載對象時反注冊零碎鉤子
        MyBase.Finalize()
    End Sub

#End Region

    /**/''' <summary>開端裝置零碎鉤子</summary>
    ''' <param name="InstallKeyboardHook">掛鉤鍵盤音訊</param>
    ''' <param name="InstallMouseHook">掛鉤鼠標音訊</param>
    Public Sub StartHook()Sub StartHook(Optional ByVal InstallKeyboardHook As Boolean = True, Optional ByVal InstallMouseHook As Boolean = False)
        '注冊鍵盤鉤子
        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
        '注冊鼠標鉤子
        If InstallMouseHook AndAlso hMouseHook = 0 Then
            MouseHookProcedure = New HookProc(AddressOf MouseHookProc)
            hMouseHook = SetWindowsHookEx(WH_MOUSE_LL, MouseHookProcedure, Marshal.GetHINSTANCE(Assembly.GetExecutingAssembly.GetModules()(0)), 0)
            If hMouseHook = 0 Then
                UnHook(False, True)
                Throw New Win32Exception(Marshal.GetLastWin32Error)
            End If
        End If
    End Sub
    /**/''' <summary>立即卸載零碎鉤子</summary>
    ''' <param name="UninstallKeyboardHook">卸載鍵盤鉤子 </param>
    ''' <param name="UninstallMouseHook">卸載鼠標鉤子</param>
    ''' <param name="ThrowExceptions">能否報告錯誤</param>
    Public Sub UnHook()Sub UnHook(Optional ByVal UninstallKeyboardHook As Boolean = True, Optional ByVal UninstallMouseHook 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
        '卸載鼠標鉤子
        If hMouseHook <> 0 AndAlso UninstallMouseHook Then
            Dim retMouse As Integer = UnhookWindowsHookEx(hMouseHook)
            hMouseHook = 0
            If ThrowExceptions AndAlso retMouse = 0 Then
                Throw New Win32Exception(Marshal.GetLastWin32Error)
            End If
        End If
    End Sub

    '鍵盤音訊的委托處置代碼
    Private Function KeyboardHookProc()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 (TODO:此段代碼還有BUG!)
            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))
                    ' BUG所在
                    'If isDownCapslock Xor isDownShift And Char.IsLetter(key) Then
                    '    key = Char.ToUpper(key)
                    'End If
                    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)
        End If
    End Function
    '鼠標音訊的委托處置代碼
    Private Function MouseHookProc()Function MouseHookProc(ByVal nCode As Integer, ByVal wParam As Integer, ByVal lParam As IntPtr) As Integer
        If nCode >= 0 AndAlso events("MouseActivity") IsNot Nothing Then
            Static mouseHookStruct As MouseLLHookStruct
            mouseHookStruct = DirectCast(Marshal.PtrToStructure(lParam, GetType (MouseLLHookStruct)), MouseLLHookStruct)
            Static moubut As MouseButtons : moubut = MouseButtons.None '鼠標按鍵
            Static mouseDelta As Integer : mouseDelta = 0 '滾輪值
            Select Case wParam
                Case WM_LBUTTONDOWN
                    moubut = MouseButtons.Left
                Case WM_RBUTTONDOWN
                    moubut = MouseButtons.Right
                Case WM_MBUTTONDOWN
                    moubut = MouseButtons.Middle
                Case WM_MOUSEWHEEL
                    Static int As Integer : int = (mouseHookStruct.MouseData >> 16) And &HFFFF
                    '本段代碼CLE添加,模擬C#的Short從Int棄位轉換
                    If int > Short.MaxValue Then mouseDelta = int - 65536 Else mouseDelta = int
            End Select
            Static clickCount As Integer : clickCount = 0 '單擊次數
            If moubut <> MouseButtons.None Then
                If wParam = WM_LBUTTONDBLCLK OrElse wParam = WM_RBUTTONDBLCLK OrElse wParam = WM_MBUTTONDBLCLK Then
                    clickCount = 2
                Else
                    clickCount = 1
                End If
            End If
            Dim e As New MouseEventArgs(moubut, clickCount, mouseHookStruct.PT.X, mouseHookStruct.PT.Y, mouseDelta)
            RaiseEvent MouseActivity(Me, e)
        End If
        Return CallNextHookEx(hMouseHook, nCode, wParam, lParam) '激活下一個鉤子
    End Function

    /**/''' <summary>鍵盤鉤子能否無效</summary>
    Public Property KeyHookEnabled()Property KeyHookEnabled() As Boolean
        Get
            Return hKeyboardHook <> 0
        End Get
        Set(ByVal value As Boolean)
            If value Then StartHook(True, False) Else UnHook(True, False)
        End Set
    End Property
    /**/''' <summary>鼠標鉤子能否無效</summary>
    Public Property MouseHookEnabled()Property MouseHookEnabled() As Boolean
        Get
            Return hMouseHook <> 0
        End Get
        Set(ByVal value As Boolean)
            If value Then StartHook(False, True) Else UnHook(False, True)
        End Set
    End Property

End Class

  1. 上一頁:
  2. 下一頁:
Copyright © 程式師世界 All Rights Reserved