mdlhook.bas

本系统可用于医院和专业体检中心的健康体检管理

Attribute VB_Name = "mdlHook"
Option Explicit

Public 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
Public Declare Function UnhookWindowsHookEx Lib "user32" _
    (ByVal hHook As Long) As Long
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
        ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
        (lpvDest As Any, ByVal lpvSource As Long, ByVal cbCopy As Long)
Public Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Public Type POINTAPI
    x As Long
    y As Long
End Type
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WH_MOUSE = 7
Public Const WM_RBUTTONDOWN = &H204
Public Const HC_ACTION = 0
Public Const WM_RBUTTONUP = &H205

Public hHook As Long   ' handle of Hook Procedure
 
Public Sub EnableHook(ByVal hWnd As Long)
    If hHook = 0 Then
       hHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseHookProc, App.hInstance, 0)  '
    End If
End Sub
 
Public Sub FreeHook()
    Dim ret As Long
    If hHook <> 0 Then
       ret = UnhookWindowsHookEx(hHook)
       hHook = 0
    End If
End Sub
 
Function MouseHookProc(ByVal code As Long, ByVal wParam As Long, _
                 ByVal lParam As Long) As Long
    If code < 0 Then
        MouseHookProc = CallNextHookEx(hHook, code, wParam, lParam)
        Exit Function
    End If
    
    If wParam = WM_LBUTTONDBLCLK Or wParam = WM_RBUTTONUP Then
        Debug.Print code; wParam; lParam
        frmBrowser.RequestMouseEvent wParam
        
'        MouseHookProc = 1 '表示不處理這個訊息
'        Exit Function
    End If
    MouseHookProc = 0 '表示要處理這個訊息
    Call CallNextHookEx(hHook, code, wParam, lParam)
End Function