浏览器

开发平台：
Visual Basic

mGlobalInputHook.bas：源码内容
							Attribute VB_Name = "mGlobalInputHook"
Option Explicit
Public Declare Function GetForegroundWindow Lib "user32" () As Long
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
Public Const KF_UP As Long = &H80000000
Private Const ClassName_IE As String = "Internet Explorer_Server"
Private Const ClassName_Flash As String = "MacromediaFlashPlayerActiveX"
Private Const ClassName_ShellEmbedding As String = "Shell Embedding"
Private Const ClassName_ShellDocObjectView As String = "Shell DocObject View"
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 bigGap As Integer = 15 * 15
Private Const smallGap As Integer = 3 * 3
'Private Const mGap As Integer = 2
Private mbtnDown As Boolean
Private PointFormFrame As Object
Private InRollMode As Boolean
'Public tg1 As Single
'Public tg2 As Single
'Public tg3 As Single
'Public tg4 As Single
'右键点击的页面
Private hDoWeb As Long
'Private hasCapture As Boolean
''鼠标各方向功能
'Public Const mouseEventCount As Long = 8
'Public mouse_event_prc(0 To mouseEventCount - 1) As New cCallByName
'Public def_mouse_event(0 To mouseEventCount - 1) As Long
'按着左键单击右键
Public mouse_event_leftright As New cCallByName
Public def_mouse_event_leftright As Long
Public mouse_event_rightleft As New cCallByName
Public def_mouse_event_rightleft As Long
Private DownClassName As String
Private BeginFucntion As Boolean
Private BeginMouseEvent As Boolean
'是否正在拖动网页内容
Public WebDraging As Boolean
'######  keyboard hook ############
'鼠标手势等变量
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
Public Sub InstallKeyboardHook()
    hKeyboardHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf KeyboardHookProc, _
            App.hInstance, App.ThreadID)
End Sub
Public Function KeyboardHookProc(ByVal iCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim Cancel As Long
Cancel = 0
If iCode = HC_ACTION Then
    If (lParam And KF_UP) = 0 Then
        If wParam = vbKeyE And vkPress(VK_CONTROL) And vkPress(VK_SHIFT) Then
            gMainForm.Enabled = True
        End If
    End If
    If GetForegroundWindow() = gMainForm.hwnd Then
        If (lParam And KF_UP) = 0 Then
            Cancel = gMainForm.DropMenu_KeyDown(wParam, lParam)
        Else
            Cancel = gMainForm.DropMenu_KeyUp(wParam, lParam)
        End If
    End If
'    Select Case wParam
'        Case vbKeyF6
'            If vkPress(VK_CONTROL) Then
'                gMainForm.cmbSearch.SetFocus
'            Else
'                gMainForm.cmbAdd.SetFocus
'            End If
'        Case vbKeyF3
'            If (KF_UP And lParam) = 0 Then
'                gMainForm.FindKeyWord
'            End If
'        Case vbKeyTab
'            If vkPress(VK_CONTROL) Then
'                If vkPress(VK_SHIFT) Then
'                    If (KF_UP And lParam) = 0 Then
'                        gMainForm.NextLastTab False
'                        Cancel = 1
'                    End If
'                Else
'                    If (KF_UP And lParam) = 0 Then
'                        gMainForm.NextLastTab True
'                        Cancel = 1
'                    End If
'                End If
'            End If
'    End Select
End If
If Cancel = 1 Then
    KeyboardHookProc = 1
Else
    KeyboardHookProc = CallNextHookEx(hKeyboardHook, iCode, wParam, lParam)
End If
End Function
Public Sub UninstallKeyboardHook()
    If hKeyboardHook <> 0 Then
        Call UnhookWindowsHookEx(hKeyboardHook)
    End If
    hKeyboardHook = 0
End Sub
'######### 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
On Error GoTo due
Dim i&
Dim nMouseInfo As MOUSEHOOKSTRUCT
Dim tHWindowFromPoint As Long
Dim tPt As POINTAPI
Dim webRect As RECT
If iCode = HC_ACTION Then
    If loadedBrowserCount > 0 Then
        If GetForegroundWindow = gMainForm.hwnd Then
            CopyMemory nMouseInfo, ByVal lParam, Len(nMouseInfo)
            tPt = nMouseInfo.pt
            ScreenToClient nMouseInfo.hwnd, tPt
            If nMouseInfo.wHitTestCode = 1 Then
                ClassNameFlag = GetClassNameFlag(nMouseInfo.hwnd)
                If ClassNameFlag > 0 Then
                    Cancel = HandelWeb(wParam, webbState(gActiveWebIndex).webForm, nMouseInfo.hwnd, tPt, nMouseInfo.pt)
                End If
            End If
        End If
    End If
    
End If
If Cancel Then
    MouseHookProc = 1
Else
    MouseHookProc = CallNextHookEx(hMouseHook, iCode, wParam, lParam)
End If
Exit Function
due:
    ErrorLog.AddLog "mousehookproc" & Chr(9) & Err.Description
    
End Function
Public Sub UninstallMouseHook()
    If hMouseHook <> 0 Then
        Call UnhookWindowsHookEx(hMouseHook)
    End If
    hMouseHook = 0
End Sub
Private Function HandelWeb(wParam As Long, nWebForm As frmBrowser, hWeb 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
'Dim isBF As Boolean
rtn = False
Select Case wParam
    Case WM_LBUTTONUP
        nWebForm.nTimer = Timer
    Case WM_LBUTTONDOWN
        If vkPress(VK_RBUTTON) Then
            BeginFucntion = False
            gMainForm.ChangeStatusText mouse_event_rightleft.EventText
            mouse_event_rightleft.Execute nWebForm
            rtn = True
        Else
            nWebForm.nTimer = Timer
        End If
    Case WM_MBUTTONDOWN
        If Rollmode = 0 Then
            pX = mPt.x: pY = mPt.y
            'Set PointFormFrame = FindFrameFromPoint(nWebForm.webMe.Document, screenPt)
            Set PointFormFrame = nWebForm.FindFrameFromPoint(screenPt.x, screenPt.y)
            mbtnDown = True
        End If
        rtn = True
    Case WM_MBUTTONUP
        If Rollmode = 0 Then
            mbtnDown = False
            Set PointFormFrame = Nothing
        Else
            InRollMode = Not InRollMode
            If InRollMode Then
                pX = mPt.x: pY = mPt.y
                'Set PointFormFrame = FindFrameFromPoint(nWebForm.webMe.Document, screenPt)
                Set PointFormFrame = nWebForm.FindFrameFromPoint(screenPt.x, screenPt.y)
            End If
        End If
    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)
'                isBF = False
'                If Not hasCapture Then
'                    If cx * cx + cy * cy > smallGap Then
'                        SetCapture hWeb
'                        hasCapture = True
'                    End If
'                End If
                If Not BeginMouseEvent Then
                    If cx * cx + cy * cy > smallGap Then
                        'ReleaseCapture
                        BeginMouseEvent = True
                    End If
                End If
                Call GetMouseEvent(mPt)
'                If cx * cx + cy * cy > bigGap Then
'                    If cy >= cx * tg1 And cy < cx * tg2 Then
'                        tDir = 0
'                    ElseIf cy >= cx * tg2 And cy > cx * tg3 Then
'                        tDir = 1
'                    ElseIf cy <= cx * tg3 And cy > cx * tg4 Then
'                        tDir = 2
'                    ElseIf cy <= cx * tg4 And cy > cx * tg1 Then
'                        tDir = 3
'                    ElseIf cy <= cx * tg1 And cy > cx * tg2 Then
'                        tDir = 4
'                    ElseIf cy <= cx * tg2 And cy < cx * tg3 Then
'                        tDir = 5
'                    ElseIf cy >= cx * tg3 And cy < cx * tg4 Then
'                        tDir = 6
'                    ElseIf cy >= cx * tg4 And cy < cx * tg1 Then
'                        tDir = 7
'                    End If
'                    If tDir > -1 Then
'                        gMainForm.ChangeStatusText (mouse_event_prc(tDir).EventText)
'                    End If
'                Else
'                    gMainForm.ChangeStatusText ("")
'                    'Call SetCursor(hPreCur)
'                End If
            End If
            rtn = True
        ElseIf vkPress(VK_MBUTTON) And mbtnDown Then
            Call MoveDocument(mPt)
        ElseIf InRollMode Then
            Call MoveDocument(mPt)
        End If
    Case WM_RBUTTONDOWN
        rtn = True
        If vkPress(VK_LBUTTON) Or vkPress(VK_CONTROL) Then
            'If Not WebDraging Then
            If Not gSelfDrag.SelfDraging Then
                ReleaseCapture
                'gMainForm.UnloadBrowser nWebForm.tagIndex
                gMainForm.ChangeStatusText mouse_event_leftright.EventText
                mouse_event_leftright.Execute nWebForm
                rtn = True
            End If
            
        ElseIf vkPress(VK_RBUTTON) Then
            rtn = True
            If ClassNameFlag > 0 Then
                If GetClassNameFlag(WindowFromPoint(screenPt.x, screenPt.y)) > 0 Then
                    BeginFucntion = True
                    'BeginMouseEvent = False
    '                hasCapture = False
                    hDoWeb = hWeb
                    
                    'hPreCur = GetCursor()
        
        
                    'Call getXY(lParam, pX, pY)
                    pX = mPt.x: pY = mPt.y
                    
                    preDir = -1
                    mHand(0) = 0: mHand(1) = 0: mHand(2) = 0
                    mHandPoint = 0
                End If
            Else
                BeginFucntion = False
            End If
        End If
'==============================================
    Case WM_RBUTTONUP
        rtn = True
        If vkPress(VK_LBUTTON) Or vkPress(VK_CONTROL) Then
'            ReleaseCapture
'            gMainForm.unloadBrowser nWebForm.tagIndex
'            rtn = True
        Else
            If BeginFucntion Then
                BeginFucntion = False
                If BeginMouseEvent Then
                    
                    If hWeb = hDoWeb Then
                        'Call HandleMouseEvent(nWebForm, mPt, hWeb)
                        Call HandleMouseEvent2(nWebForm, mPt, hWeb)
                    End If
                    
                    'ReleaseCapture
                    
                    rtn = BeginMouseEvent
                    BeginMouseEvent = False
                Else
                    rtn = True
                    Call PostMessage(hWeb, WM_RBUTTONDOWN, _
                        MK_RBUTTON, ByVal MAKELONG(mPt.x, mPt.y))
                    If ClassNameFlag > 1 Then
                        Call PostMessage(hWeb, WM_RBUTTONUP, _
                            MK_RBUTTON, ByVal MAKELONG(mPt.x, mPt.y))
                    End If
                End If
            End If
        End If
        
'        If hasCapture Then
'            Call ReleaseCapture
'            rtn = True
'            hasCapture = False
'        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
Public Function vkPress(vkcode As Long) As Boolean
If (GetAsyncKeyState(vkcode) And &H8000) <> 0 Then
    vkPress = True
Else
    vkPress = False
End If
End Function
'Private Function FindFrameFromPoint(nDoc As Object, nPt As POINTAPI) As Object
'On Error Resume Next
'Dim i&
'Dim frameCnt&
'Dim tDoc As Object
'Dim trc As RECT
'Dim rtn As Object
'Dim inSubFrame As Boolean
'inSubFrame = False
'
'frameCnt = nDoc.frames.Length
'For i = 0 To frameCnt - 1
'
'    Set tDoc = Nothing
'    Set tDoc = nDoc.frames(i).Document
'    If Not tDoc Is Nothing Then
'        Set rtn = FindFrameFromPoint(tDoc, nPt)
'        If Not rtn Is Nothing Then
'            inSubFrame = True
'            Exit For
'        End If
'    End If
'Next i
'
''不在其子Frame时
'If Not inSubFrame Then
'    trc.Top = nDoc.parentWindow.screenTop
'    trc.Left = nDoc.parentWindow.screenLeft
'    trc.Right = trc.Left + nDoc.body.clientWidth
'    trc.Bottom = trc.Top + nDoc.body.clientHeight
'
'    If PtInRect(trc, nPt.x, nPt.y) Then
'        Set rtn = nDoc.parentWindow
'    End If
'End If
'
'Set FindFrameFromPoint = rtn
'
'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 HandleMouseEvent(nWebForm As frmBrowser, mPt As POINTAPI, nHwnd As Long)
'Dim rtn As Boolean
'Dim xpos As Long, ypos As Long, cx As Long, cy As Long
'
'Dim tDirection As Long
'
''Call SetCursor(hPreCur)
'xpos = mPt.x: ypos = mPt.y
'cx = xpos - pX: cy = -(ypos - pY)
''isBF = False
'tDirection = -1
'If cx * cx + cy * cy > bigGap Then
'    If cy >= cx * tg1 And cy < cx * tg2 Then
'        tDirection = 0
'    ElseIf cy >= cx * tg2 And cy > cx * tg3 Then
'        tDirection = 1
'    ElseIf cy <= cx * tg3 And cy > cx * tg4 Then
'        tDirection = 2
'    ElseIf cy <= cx * tg4 And cy > cx * tg1 Then
'        tDirection = 3
'    ElseIf cy <= cx * tg1 And cy > cx * tg2 Then
'        tDirection = 4
'    ElseIf cy <= cx * tg2 And cy < cx * tg3 Then
'        tDirection = 5
'    ElseIf cy >= cx * tg3 And cy < cx * tg4 Then
'        tDirection = 6
'    ElseIf cy >= cx * tg4 And cy < cx * tg1 Then
'        tDirection = 7
'    End If
'    Debug.Print tDirection
'    If tDirection > -1 Then
''        isBF = True
'        'ReleaseCapture
'        'SendMessage nHwnd, WM_CANCELMODE, 0&, 0&
'        'DoEvents
'        mouse_event_prc(tDirection).Execute nWebForm
'    End If
'End If
'
'End Sub
Private Sub HandleMouseEvent2(nWebForm As frmBrowser, mPt As POINTAPI, nHwnd As Long)
'Dim tKey$
Dim tObj As cCallByName
If mHandPoint <= 3 Then
    Set tObj = MouseHand.GetCallObject_ByKey2(mHand)
    If Not tObj Is Nothing Then
        Debug.Print "HandleMouseEvent2", tObj.InsideIndex
        DoEvents
        tObj.Execute nWebForm
    End If
End If
gMainForm.ChangeStatusText ""
End Sub
Private Function GetClassNameVb(nHwnd As Long) As String
Dim rtn As String, tLen&
rtn = Space(255)
tLen = GetClassName(nHwnd, rtn, 255)
If tLen > 0 Then
    rtn = Left(rtn, tLen)
Else
    rtn = ""
End If
GetClassNameVb = rtn
End Function
'Private Sub PopFavoriteMenu(ByVal wParam As Long, ByVal lParam As Long)
'Dim tMHS As MOUSEHOOKSTRUCT
'Dim tHwnd&, tMenuPos&
'If wParam = WM_RBUTTONUP Then
'    CopyMemory tMHS, ByVal lParam, Len(tMHS)
'    tHwnd = WindowFromPoint(tMHS.pt.x, tMHS.pt.y)
'    Debug.Print tMHS.hwnd, tHwnd, gMainForm.hMnuFavorite
'    If tHwnd <> 0 Then
'        Debug.Print gMainForm.hwnd
'        If IsMenu(tHwnd) <> 0 Then
'            tMenuPos = MenuItemFromPoint(gMainForm.hwnd, tHwnd, tMHS.pt)
'            Debug.Print tMenuPos
'        End If
'    End If
'End If
'End Sub
'Private Function FindFrameFromPoint(nDoc As Object, nPt As POINTAPI) As Object
'On Error Resume Next
'Dim i&
'Dim frameCnt&
'Dim tDoc As Object
'Dim tRc As RECT
'Dim rtn As Object
'Dim inSubFrame As Boolean
'inSubFrame = False
'
'frameCnt = nDoc.Frames.Length
'For i = 1 To frameCnt
'
'    Set tDoc = Nothing
'    Set tDoc = nDoc.Frames(i).Document
'
'    If Not tDoc Is Nothing Then
'        tRc.Top = nDoc.Frames(i).screenTop
'        tRc.Left = nDoc.Frames(i).screenLeft
'        tRc.Right = tRc.Left + tDoc.body.ClientWidth
'        tRc.Bottom = tRc.Top + tDoc.body.ClientHeight
'
'        If PtInRect(tRc, nPt.x, nPt.y) Then
'            Set rtn = nDoc.Frames(i)
'            inSubFrame = True
'            Exit For
'        End If
'    End If
'Next i
'
'If Not inSubFrame Then
'    Set rtn = nDoc.parentwindow
'End If
'
'Set FindFrameFromPoint = rtn
'
'End Function
Public Function MAKELONG(wLow As Long, wHigh As Long) As Long
MAKELONG = wHigh * &H10000 + wLow
End Function
Public Function GetClassNameFlag(nHwnd As Long) As Long
'Dim ClassNmaeFlag As Long
Dim DownClassName As String
DownClassName = GetClassNameVb(nHwnd)
Select Case DownClassName
    Case ClassName_IE
        ClassNameFlag = 2
    Case ClassName_Flash
        ClassNameFlag = 1
    Case ClassName_ShellDocObjectView
        ClassNameFlag = 8
    Case ClassName_ShellEmbedding
        ClassNameFlag = 4
    Case Else
        ClassNameFlag = 0
End Select
GetClassNameFlag = ClassNameFlag
End Function
Public Function GetMouseEvent(nPt As POINTAPI) As Long
Dim cx&, cy&
Dim rtn&
Dim tStu$
Dim tObj As cCallByName
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
        tStu = "鼠标手势: "
        If mHandPoint < 3 Then
            mHandPoint = mHandPoint + 1
            mHand(mHandPoint - 1) = rtn
            
            tStu = tStu & DebugDir(mHand(0)) & DebugDir(mHand(1)) & _
                        DebugDir(mHand(2))
            Set tObj = MouseHand.GetCallObject_ByKey2(mHand)
            If Not tObj Is Nothing Then
                tStu = tStu & " => " & tObj.EventText
            End If
        Else
            mHandPoint = 4
            tStu = tStu & "(无效)"
        End If
        'Call DebugDir(rtn)
        gMainForm.ChangeStatusText tStu
        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

						