程式師世界 >> 編程語言 >> .NET網頁編程 >> .NET實例教程 >> prjBrowser

prjBrowser

編輯：.NET實例教程

prjBrowser - 具有停靠效果的浏覽器 - 類似QQ停靠效果 - VB6 + API

modAPI.bas

Option Explicit
'###################################################################################################################

'設置窗體位置
Public Declare Function SetWindowPos Lib "user32" _
    ( _
    ByVal hwnd As Long, _
    ByVal hWndInsertAfter As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal cx As Long, _
    ByVal cy As Long, _
    ByVal wFlags As Long _
    ) As Long

'--------------------------------------------------------------------------------------------------------
'hWndInsertAfter Parameter Value
Public Const HWND_BOTTOM = 1
Public Const HWND_BROADCAST = &HFFFF&
Public Const HWND_DESKTOP = 0
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOP = 0
Public Const HWND_TOPMOST = -1

'--------------------------------------------------------------------------------------------------------
'wFlags Paramter Value
Public Const SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_NOCOPYBITS = &H100
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
Public Const SWP_NOREDRAW = &H8
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Public Const SWP_NOZORDER = &H4
Public Const SWP_SHOWWINDOW = &H40
Public Const SWP_DRAWFRAME = SWP_FRAMECHANGED
'###################################################################################################################

'類似QQ，窗體自動上浮API

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 CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long

Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Public Type POINTAPI
X As Long
Y As Long
End Type

Public Type MSLLHOOKSTRUCT
     pt As POINTAPI
     mouseData As Long
     Flags As Long
     time As Long
     dwExtraInfo As Long
End Type

Public Const WH_MOUSE_LL As Long = 14

Public Const WM_MOUSEMOVE = &H200

Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

'###########################################################################################################

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As Long, _
        ByVal lpOperation As String, _
        ByVal lpFile As String, _
        ByVal lpParameters As String, _
        ByVal lpDirectory As String, _
        ByVal nShowCmd As Long) As Long

Public Const SW_SHOWNORMAL = 1

modPub.bas

Option Explicit

Public Const conOutSideLength = 100 '停靠時，暴露在外面的長度
Public Const conInsideLength = -100 '顯示時，在屏幕外面的長度

Public hSetWindowsHookEx As Long
Public bHooking As Boolean
Public bCursorInForm As Boolean

Public Function RemoveHook()
UnhookWindowsHookEx hSetWindowsHookEx
bHooking = False
End Function

Public Function InstallHook()
    hSetWindowsHookEx = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, App.hInstance, 0)
'    Debug.Print "SetWindowsHookEx：" & hSetWindowsHookEx
'    MsgBox hSetWindowsHookEx
    bHooking = True

End Function

Public Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim typMHS As MSLLHOOKSTRUCT
    Dim pt As POINTAPI
    Dim rectWindowPosSize As RECT

    If nCode >= 0 Then
        If wParam = WM_MOUSEMOVE Then
            Call CopyMemory(typMHS, ByVal lParam, LenB(typMHS))
            pt = typMHS.pt
    '        With frmMain
    '            .txtX = pt.X
    '            .txtY = pt.Y
    '        End With

GetWindowRect frmMain.hwnd, rectWindowPosSize

            With frmMain
                If .Windowstate = 0 Then
                    '移出窗體
                    If (pt.X < rectWindowPosSize.Left Or pt.X > rectWindowPosSize.Right Or _
                      pt.Y < rectWindowPosSize.Top Or pt.Y > rectWindowPosSize.Bottom) Then
                       If bCursorInForm = True Then
                       If .Top <= 0 Then                           '上停靠 - 進去
                           .Top = conOutSideLength - .Height
                       ElseIf .Left <= 0 Then                      '左停靠 - 進去
                           .Left = conOutSideLength - .Width
                       ElseIf .Left >= Screen.Width - .Width Then '右停靠 - 進去
                           .Left = Screen.Width - conOutSideLength
                       End If
                       bCursorInForm = False
        '              RemoveHook
                       End If
                    '移入窗體
                    Else
                       If bCursorInForm = False Then
                        If .Top < conInsideLength Then                                      '上停靠 - 出來
                            .Top = conInsideLength
                        ElseIf .Left < conInsideLength Then                                 '左停靠 - 出來
                            .Left = conInsideLength
                        ElseIf .Left > Screen.Width - .Width + conInsideLength Then         '右停靠 - 出來
                            .Left = Screen.Width - .Width - conInsideLength
                        End If
                        bCursorInForm = True
        '               InstallHook
                       End If
                    End If
                End If
            End With
        End If
    End If
'    Debug.Print CallNextHookEx(hSetWindowsHookEx, nCode, wParam, lParam)
    Debug.Print "CallNextHookEx：" & hSetWindowsHookEx
    LowLevelMouseProc = CallNextHookEx(hSetWindowsHookEx, nCode, wParam, lParam)
End Function

frmMain.frm

Option Explicit

Private Sub Form_Load()
    With wb
        .AddressBar = True
        .StatusBar = True
        .Navigate "http://blog.csdn.Net/HackerJLY"

    End With
    With timerAutoRefresh
        .Interval = 10000
    End With
    With mnuAutoRefresh
        .Checked = False

    End With

    With Me
        .Left = 0
        .Top = 0
        .Height = Screen.Height - 500
        .Width = 4500

    End With

    '窗體置頂

    SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, Screen.Width / 60, Screen.Height / 15.4, SWP_SHOWWINDOW

    InstallHook

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'    If bHooking = False Then
'        With Me
'            If .Top < conInsideLength Then                                      '上停靠
'                .Top = conInsideLength
'                InstallHook
'            ElseIf .Left < conInsideLength Then                                 '左停靠
'                .Left = conInsideLength
'                InstallHook
'            ElseIf .Left > Screen.Width - .Width + conInsideLength Then         '右停靠
'                .Left = Screen.Width - .Width - conInsideLength
'                InstallHook
'            End If
'        End With
'    End If

End Sub

Private Sub Form_Resize()
    On Error Resume Next
    With wb
        .Left = 50
        .Width = Me.ScaleWidth - .Left - 50
        .Top = txtURL.Height + 200
        .Height = Me.ScaleHeight - .Top - 100
    End With
    With txtURL
        .Width = Me.ScaleWidth - lblURL.Width
        .Left = lblURL.Width



    End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim rtn As Integer
    rtn = MsgBox("確定要關閉嗎？", vbYesNo + vbDefaultButton2 + vbInformation, "Browser")
    If rtn <> vbYes Then
        Cancel = 1
    Else
        If bHooking = True Then
            RemoveHook
        End If
    End If
End Sub

Private Sub mnuAboutHackerJLYCNBlogs_Click()
ShellExecute 0, "open", "http://HackerJLY.cnblogs.com", vbNullString, vbNullString, SW_SHOWNORMAL
End Sub

Private Sub mnuAboutHackerJLYCSDN_Click()
ShellExecute 0, "open", "http://blog.csdn.Net/HackerJLY", vbNullString, vbNullString, SW_SHOWNORMAL
End Sub

Private Sub mnuAboutHackerJLYLive_Click()
ShellExecute 0, "open", "http://HackerJLY.spaces.live.com", vbNullString, vbNullString, SW_SHOWNORMAL
End Sub

Private Sub mnuAutoRefresh_Click()
With timerAutoRefresh

;    If .Enabled = True Then
            .Enabled = False
            mnuAutoRefresh.Checked = False
        Else
            .Enabled = True
            mnuAutoRefresh.Checked = True
        End If
    End With
End Sub

Private Sub mnuHackerJLYBlogCNBlogs_Click()
wb.Navigate "http://HackerJLY.cnblogs.com"
End Sub

Private Sub mnuHackerJLYBlogCSDN_Click()
wb.Navigate "http://blog.csdn.Net/HackerJLY"
End Sub

Private Sub mnuMSNFavorites_Click()
wb.Navigate "http://favorites.live.com/messenger.ASPx"
End Sub

Private Sub mnuReFresh_Click()
wb.Refresh
End Sub

Private Sub mnuStop_Click()
wb.Stop
End Sub

Private Sub mnuTreeMSDNLibraryChs_Click()
wb.Navigate "http://msdn2.microsoft.com/zh-cn/library/default(d=toc).ASPx"
End Sub

Private Sub mnuTreeMSDNLibraryEng_Click()
wb.Navigate "http://msdn2.microsoft.com/en-us/library/default(d=toc).ASPx"
End Sub

Private Sub mnuTreeTechNetLibraryChs_Click()
wb.Navigate "http://technet.microsoft.com/zh-cn/library/default(d=toc).ASPx"
End Sub

Private Sub mnuTreeTechNetLibraryEng_Click()
wb.Navigate "http://technet.microsoft.com/en-us/library/default(d=toc).ASPx"
End Sub

Private Sub mnuTreeTechNetLibraryEngLater_Click()
wb.Navigate "http://www.microsoft.com/technet/mnp_utility.mspx/framesmenu?url=/technet/archive/default.mspx"
End Sub

Private Sub timerAutoRefresh_Timer()
wb.Refresh
End Sub

Private Sub txtURL_DblClick()
txtURL_GotFocus
End Sub

Private Sub txtURL_GotFocus()
txtURL.SelStart = 0
txtURL.SelLength = Len(txtURL.Text)
End Sub

Private Sub txtURL_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn Then wb.Navigate txtURL.Text
End Sub

Private Sub wb_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
txtURL.Text = URL
End Sub

Private Sub wb_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
Me.Caption = wb.LocationName & " - Browser"
End Sub