浏览器

开发平台：
Visual Basic

mMouseHook.bas：源码内容
							Attribute VB_Name = "mMouseHook"
Option Explicit
'#####  keyboard and mouse hook ##################
Public Type POINTAPI
    x As Long
    y As Long
End Type
Public Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type
Public Declare Function CallNextHookEx Lib "user32" _
        (ByVal hHook As Long, _
        ByVal ncode As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long
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 Const WH_KEYBOARD As Long = 2
Public Const WH_MOUSE As Long = 7
Public Const HC_SYSMODALOFF = 5
Public Const HC_SYSMODALON = 4
Public Const HC_SKIP = 2
Public Const HC_GETNEXT = 1
Public Const HC_ACTION = 0
Public Const HC_NOREMOVE As Long = 3
'##########################################
Public Const HTCLIENT As Long = 1
Private hKeyboardHook As Long
Private hMouseHook As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Const KF_UP As Long = &H80000000
Private ClassNameFlag As Long
Dim pX As Long, pY As Long
Dim afterBF As Boolean
Dim nowCur As Integer
Dim hPreCur As Long
Private Const smallGap As Integer = 3 * 3
Private mbtnDown As Boolean
Private PointFormFrame As Object
Private InRollMode As Boolean
'右键点击的页面
Private hDoWeb As Long
Private DownClassName As String
Private BeginFucntion As Boolean
Private BeginMouseEvent As Boolean
'是否正在拖动网页内容
Public WebDraging As Boolean
'鼠标手势等变量
'Public MouseHand As New cMouseEvent
Const ptGap As Single = 5 * 5
Dim preDir As Long
Private mHand(0 To 2) As Byte
Private mHandPoint As Long
'######### mouse hook #############
Public Sub InstallMouseHook()
    hMouseHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseHookProc, _
            App.hInstance, App.ThreadID)
End Sub
Public Function MouseHookProc(ByVal iCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim Cancel As Boolean
Cancel = False
Dim i&
Dim nMouseInfo As MOUSEHOOKSTRUCT
Dim tHWindowFromPoint As Long
Dim tPt As POINTAPI
Dim webRect As RECT
'Dim tClassName As String
If iCode = HC_ACTION Then
    CopyMemory nMouseInfo, ByVal lParam, Len(nMouseInfo)
    tPt = nMouseInfo.pt
    If IsWebCtrl(nMouseInfo.hwnd) Then
        ScreenToClient nMouseInfo.hwnd, tPt
        Cancel = HandelWeb(nMouseInfo.hwnd, wParam, tPt, nMouseInfo.pt)
    End If
End If
If Cancel Then
    MouseHookProc = 1
Else
    MouseHookProc = CallNextHookEx(hMouseHook, iCode, wParam, lParam)
End If
End Function
Public Sub UninstallMouseHook()
    If hMouseHook <> 0 Then
        Call UnhookWindowsHookEx(hMouseHook)
    End If
    hMouseHook = 0
End Sub
'Private Function HandelWeb(wParam As Long, hWeb As Long, mPt As POINTAPI, screenPt As POINTAPI) As Boolean
Private Function HandelWeb(hWeb As Long, wParam As Long, mPt As POINTAPI, screenPt As POINTAPI) As Boolean
On Error GoTo due
Dim rtn As Boolean
Dim xpos As Long, ypos As Long, cx As Long, cy As Long
rtn = False
Select Case wParam
    Case WM_MOUSEMOVE
        If vkPress(VK_RBUTTON) Then
            If BeginFucntion Then
                Dim tDir As Long: tDir = -1
                xpos = mPt.x: ypos = mPt.y
                cx = xpos - pX: cy = -(ypos - pY)
                If Not BeginMouseEvent Then
                    If cx * cx + cy * cy > smallGap Then
                        BeginMouseEvent = True
                    End If
                End If
                If BeginMouseEvent Then
                    Call GetMouseEvent(mPt)
                End If
            End If
            rtn = True
        End If
    Case WM_RBUTTONDOWN
        If vkPress(VK_RBUTTON) Then
            rtn = True
            BeginFucntion = True
            pX = mPt.x: pY = mPt.y
            preDir = -1
            mHand(0) = 0: mHand(1) = 0: mHand(2) = 0
            mHandPoint = 0
        End If
    Case WM_RBUTTONUP
        rtn = True
        If BeginFucntion Then
            BeginFucntion = False
            If BeginMouseEvent Then
                Call HandleMouseEvent2(mPt, hWeb)
                BeginMouseEvent = False
            Else
                Call PostMessage(hWeb, WM_RBUTTONDOWN, _
                    MK_RBUTTON, ByVal MAKELONG(mPt.x, mPt.y))
                Call PostMessage(hWeb, WM_RBUTTONUP, _
                    MK_RBUTTON, ByVal MAKELONG(mPt.x, mPt.y))
            End If
        End If
End Select
'If wParam = WM_LBUTTONDOWN Or wParam = WM_RBUTTONDOWN Then InRollMode = False
HandelWeb = rtn 'true: cancel ; false : normal
Exit Function
due:
'   ErrorLog.AddLog "handelweb" & Chr(9) & Err.Description
   Resume Next
End Function
'Private Sub MoveDocument(mPt As POINTAPI)
'    Dim tRate As Long
'    Dim cx As Long, cy As Long
'
'    If RollInvert = 0 Then
'        tRate = 1
'    Else
'        tRate = -1
'    End If
'    If vkPress(VK_CONTROL) Then
'        cx = (mPt.x - pX) * ScrollRate2 * tRate
'        cy = (mPt.y - pY) * ScrollRate2 * tRate
'    Else
'        cx = (mPt.x - pX) * ScrollRate * tRate
'        cy = (mPt.y - pY) * ScrollRate * tRate
'    End If
'    'nWebForm.webMe.Document.parentwindow.scrollby cx, cy
'    If Not PointFormFrame Is Nothing Then
'
'        PointFormFrame.scrollBy cx, cy
'        pX = mPt.x: pY = mPt.y
'    End If
'End Sub
'
Private Sub HandleMouseEvent2(mPt As POINTAPI, nHwnd As Long)
On Error Resume Next
If mHandPoint = 1 Then
    Select Case mHand(0)
        Case 1  'right
            IEBrowser.GoForward
        Case 2  'up
            IEBrowser.Refresh
        Case 3  'left
            IEBrowser.GoBack
        Case 4  'down
            SendMessage IEBrowser.hwnd, WM_SYSCOMMAND, SC_CLOSE, 0&
    End Select
End If
End Sub
Public Function GetMouseEvent(nPt As POINTAPI) As Long
Dim cx&, cy&
Dim rtn&
rtn = -1
cx = nPt.x - pX: cy = -(nPt.y - pY)
If cx * cx + cy * cy > ptGap Then
    If cx > 0 And Abs(cy) <= cx Then
        rtn = 1
    ElseIf cy > 0 And Abs(cx) <= cy Then
        rtn = 2
    ElseIf cx < 0 And Abs(cy) <= Abs(cx) Then
        rtn = 3
    ElseIf cy < 0 And Abs(cx) <= Abs(cy) Then
        rtn = 4
    End If
    'mPt = nPt
    pX = nPt.x: pY = nPt.y
    If preDir <> rtn Then
        If mHandPoint < 3 Then
            mHandPoint = mHandPoint + 1
            mHand(mHandPoint - 1) = rtn
        Else
            mHandPoint = 4
        End If
        preDir = rtn
    End If
End If
GetMouseEvent = rtn
End Function
'Public Function DebugDir(ByVal nDir&) As String
'Dim tstr$
'Select Case nDir
'    Case 1
'        tstr = "右"
'    Case 2
'        tstr = "上"
'    Case 3
'        tstr = "左"
'    Case 4
'        tstr = "下"
'    Case Else
'        tstr = ""
'End Select
'Debug.Print Timer, tstr
'DebugDir = tstr
'End Function

						