請使用Ctrl+F5編譯程式
掛勾:
Imports System.Reflection, System.Threading, System.ComponentModel, System.Runtime.InteropServices
Public Class MouseHook
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Integer, ByVal lpfn As MouseProcDelegate, ByVal hmod As Integer, ByVal dwThreadId As Integer) As Integer
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Integer, ByVal nCode As Integer, ByVal wParam As Integer, ByVal lParam As MSLLHOOKSTRUCT) As Integer
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Integer) As Integer
Private Delegate Function MouseProcDelegate(ByVal nCode As Integer, ByVal wParam As Integer, ByRef lParam As MSLLHOOKSTRUCT) As Integer
Private Structure MSLLHOOKSTRUCT
Public pt As Point
Public mouseData As Integer
Public flags As Integer
Public time As Integer
Public dwExtraInfo As Integer
End Structure
Public Enum Wheel_Direction
WheelUp
WheelDown
End Enum
Private Const HC_ACTION As Integer = 0
Private Const WH_MOUSE_LL As Integer = 14
Private Const WM_MOUSEMOVE As Integer = &H200
Private Const WM_LBUTTONDOWN As Integer = &H201
Private Const WM_LBUTTONUP As Integer = &H202
Private Const WM_RBUTTONDOWN As Integer = &H204
Private Const WM_RBUTTONUP As Integer = &H205
Private Const WM_MBUTTONDOWN As Integer = &H207
Private Const WM_MBUTTONUP As Integer = &H208
Private Const WM_MOUSEWHEEL As Integer = &H20A
Private MouseHook As Integer
Private MouseHookDelegate As MouseProcDelegate
Public Event Mouse_Move(ByVal e As Point)
Public Event Mouse_Left_Down(ByVal e As Point)
Public Event Mouse_Left_Up(ByVal e As Point)
Public Event Mouse_Right_Down(ByVal e As Point)
Public Event Mouse_Right_Up(ByVal e As Point)
Public Event Mouse_Middle_Down(ByVal e As Point)
Public Event Mouse_Middle_Up(ByVal e As Point)
Public Event Mouse_Wheel(ByVal e As Point, ByVal Direction As Wheel_Direction)
Public Sub New()
MouseHookDelegate = New MouseProcDelegate(AddressOf MouseProc)
MouseHook = SetWindowsHookEx(WH_MOUSE_LL, MouseHookDelegate, System.Runtime.InteropServices.Marshal.GetHINSTANCE(System.Reflection.Assembly.GetExecutingAssembly.GetModules()(0)).ToInt32, 0)
End Sub
Private Function MouseProc(ByVal nCode As Integer, ByVal wParam As Integer, ByRef lParam As MSLLHOOKSTRUCT) As Integer
If (nCode = HC_ACTION) Then
Select Case wParam
Case WM_MOUSEMOVE
RaiseEvent Mouse_Move(lParam.pt)
Case WM_LBUTTONDOWN
RaiseEvent Mouse_Left_Down(lParam.pt)
Case WM_LBUTTONUP
RaiseEvent Mouse_Left_Up(lParam.pt)
Case WM_RBUTTONDOWN
RaiseEvent Mouse_Right_Down(lParam.pt)
Case WM_RBUTTONUP
RaiseEvent Mouse_Right_Up(lParam.pt)
Case WM_MBUTTONDOWN
RaiseEvent Mouse_Middle_Down(lParam.pt)
Case WM_MBUTTONUP
RaiseEvent Mouse_Middle_Up(lParam.pt)
Case WM_MOUSEWHEEL
Dim wDirection As Wheel_Direction
If lParam.mouseData < 0 Then
wDirection = Wheel_Direction.WheelDown
Else
wDirection = Wheel_Direction.WheelUp
End If
RaiseEvent Mouse_Wheel(lParam.pt, wDirection)
End Select
End If
Return CallNextHookEx(MouseHook, nCode, wParam, lParam)
End Function
Protected Overrides Sub Finalize()
UnhookWindowsHookEx(MouseHook)
MyBase.Finalize()
End Sub
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
Private WithEvents MouseHook As New MouseHook
Private Sub clear()
Lab_Left_Down.BackColor = SystemColors.Control
Lab_Left_Up.BackColor = SystemColors.Control
Lab_Middle_Down.BackColor = SystemColors.Control
Lab_Middle_Up.BackColor = SystemColors.Control
Lab_Move.BackColor = SystemColors.Control
Lab_Right_Down.BackColor = SystemColors.Control
Lab_Right_Up.BackColor = SystemColors.Control
Lab_Wheel_Down.BackColor = SystemColors.Control
Lab_Wheel_Up.BackColor = SystemColors.Control
End Sub
Private Sub MouseHook_Mouse_Left_Down(e As Point) Handles MouseHook.Mouse_Left_Down
clear()
Lab_Left_Down.BackColor = Color.GreenYellow
End Sub
Private Sub MouseHook_Mouse_Left_Up(e As Point) Handles MouseHook.Mouse_Left_Up
clear()
Lab_Left_Up.BackColor = Color.GreenYellow
End Sub
Private Sub MouseHook_Mouse_Middle_Down(e As Point) Handles MouseHook.Mouse_Middle_Down
clear()
Lab_Middle_Down.BackColor = Color.GreenYellow
End Sub
Private Sub MouseHook_Mouse_Middle_Up(e As Point) Handles MouseHook.Mouse_Middle_Up
clear()
Lab_Middle_Up.BackColor = Color.GreenYellow
End Sub
Private Sub MouseHook_Mouse_Move(e As Point) Handles MouseHook.Mouse_Move
clear()
Lab_Move.BackColor = Color.GreenYellow
End Sub
Private Sub MouseHook_Mouse_Right_Down(e As Point) Handles MouseHook.Mouse_Right_Down
clear()
Lab_Right_Down.BackColor = Color.GreenYellow
End Sub
Private Sub MouseHook_Mouse_Right_Up(e As Point) Handles MouseHook.Mouse_Right_Up
clear()
Lab_Right_Up.BackColor = Color.GreenYellow
End Sub
Private Sub MouseHook_Mouse_Wheel(e As Point, Direction As MouseHook.Wheel_Direction) Handles MouseHook.Mouse_Wheel
clear()
If Direction = MouseHook.Wheel_Direction.WheelUp Then
Lab_Wheel_Up.BackColor = Color.GreenYellow
Else
Lab_Wheel_Down.BackColor = Color.GreenYellow
End If
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
Public Class MouseHook
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Integer, ByVal lpfn As MouseProcDelegate, ByVal hmod As Integer, ByVal dwThreadId As Integer) As Integer
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Integer, ByVal nCode As Integer, ByVal wParam As Integer, ByVal lParam As MSLLHOOKSTRUCT) As Integer
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Integer) As Integer
Private Delegate Function MouseProcDelegate(ByVal nCode As Integer, ByVal wParam As Integer, ByRef lParam As MSLLHOOKSTRUCT) As Integer
Private Structure MSLLHOOKSTRUCT
Public pt As Point
Public mouseData As Integer
Public flags As Integer
Public time As Integer
Public dwExtraInfo As Integer
End Structure
Public Enum Wheel_Direction
WheelUp
WheelDown
End Enum
Private Const HC_ACTION As Integer = 0
Private Const WH_MOUSE_LL As Integer = 14
Private Const WM_MOUSEMOVE As Integer = &H200
Private Const WM_LBUTTONDOWN As Integer = &H201
Private Const WM_LBUTTONUP As Integer = &H202
Private Const WM_RBUTTONDOWN As Integer = &H204
Private Const WM_RBUTTONUP As Integer = &H205
Private Const WM_MBUTTONDOWN As Integer = &H207
Private Const WM_MBUTTONUP As Integer = &H208
Private Const WM_MOUSEWHEEL As Integer = &H20A
Private MouseHook As Integer
Private MouseHookDelegate As MouseProcDelegate
Public Event Mouse_Move(ByVal e As Point)
Public Event Mouse_Left_Down(ByVal e As Point)
Public Event Mouse_Left_Up(ByVal e As Point)
Public Event Mouse_Right_Down(ByVal e As Point)
Public Event Mouse_Right_Up(ByVal e As Point)
Public Event Mouse_Middle_Down(ByVal e As Point)
Public Event Mouse_Middle_Up(ByVal e As Point)
Public Event Mouse_Wheel(ByVal e As Point, ByVal Direction As Wheel_Direction)
Public Sub New()
MouseHookDelegate = New MouseProcDelegate(AddressOf MouseProc)
MouseHook = SetWindowsHookEx(WH_MOUSE_LL, MouseHookDelegate, System.Runtime.InteropServices.Marshal.GetHINSTANCE(System.Reflection.Assembly.GetExecutingAssembly.GetModules()(0)).ToInt32, 0)
End Sub
Private Function MouseProc(ByVal nCode As Integer, ByVal wParam As Integer, ByRef lParam As MSLLHOOKSTRUCT) As Integer
If (nCode = HC_ACTION) Then
Select Case wParam
Case WM_MOUSEMOVE
RaiseEvent Mouse_Move(lParam.pt)
Case WM_LBUTTONDOWN
RaiseEvent Mouse_Left_Down(lParam.pt)
Case WM_LBUTTONUP
RaiseEvent Mouse_Left_Up(lParam.pt)
Case WM_RBUTTONDOWN
RaiseEvent Mouse_Right_Down(lParam.pt)
Case WM_RBUTTONUP
RaiseEvent Mouse_Right_Up(lParam.pt)
Case WM_MBUTTONDOWN
RaiseEvent Mouse_Middle_Down(lParam.pt)
Case WM_MBUTTONUP
RaiseEvent Mouse_Middle_Up(lParam.pt)
Case WM_MOUSEWHEEL
Dim wDirection As Wheel_Direction
If lParam.mouseData < 0 Then
wDirection = Wheel_Direction.WheelDown
Else
wDirection = Wheel_Direction.WheelUp
End If
RaiseEvent Mouse_Wheel(lParam.pt, wDirection)
End Select
End If
Return CallNextHookEx(MouseHook, nCode, wParam, lParam)
End Function
Protected Overrides Sub Finalize()
UnhookWindowsHookEx(MouseHook)
MyBase.Finalize()
End Sub
End Class
沒有留言:
張貼留言