frmbrow.frm

使用vb程序开发的一个浏览器范例程序

         Index           =   5
      End
      Begin VB.Menu mnuNavigate 
         Caption         =   "&Search"
         Index           =   6
      End
   End
   Begin VB.Menu mnuView 
      Caption         =   "&View"
      Begin VB.Menu mnuViewFavorites 
         Caption         =   "&Favorites"
      End
      Begin VB.Menu mnuViewAddressbar 
         Caption         =   "&Address bar"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuViewStatusbar 
         Caption         =   "&Statusbar"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuViewSP1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuViewTextSize 
         Caption         =   "&Text Size"
         Begin VB.Menu mnuText 
            Caption         =   "Smallest"
            Index           =   0
         End
         Begin VB.Menu mnuText 
            Caption         =   "Smaller"
            Index           =   1
         End
         Begin VB.Menu mnuText 
            Caption         =   "Medium"
            Index           =   2
         End
         Begin VB.Menu mnuText 
            Caption         =   "Larger"
            Index           =   3
         End
         Begin VB.Menu mnuText 
            Caption         =   "Largest"
            Index           =   4
         End
      End
      Begin VB.Menu mnuViewSP2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuViewSource 
         Caption         =   "&Source"
      End
      Begin VB.Menu mnuViewInternetOptions 
         Caption         =   "&Internet Options"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "&Help"
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "&About"
      End
   End
   Begin VB.Menu mnuPopup 
      Caption         =   ""
      Visible         =   0   'False
      Begin VB.Menu mnuTV 
         Caption         =   "Add"
         Index           =   0
      End
      Begin VB.Menu mnuTV 
         Caption         =   "-"
         Index           =   1
      End
      Begin VB.Menu mnuTV 
         Caption         =   "Move to..."
         Index           =   2
      End
      Begin VB.Menu mnuTV 
         Caption         =   "Rename"
         Index           =   3
      End
      Begin VB.Menu mnuTV 
         Caption         =   "Delete"
         Index           =   4
      End
      Begin VB.Menu mnuTV 
         Caption         =   "Properties"
         Index           =   5
      End
      Begin VB.Menu mnuTV 
         Caption         =   "-"
         Index           =   6
      End
      Begin VB.Menu mnuTV 
         Caption         =   "Open folder"
         Index           =   7
      End
      Begin VB.Menu mnuTV 
         Caption         =   "New folder"
         Index           =   8
      End
      Begin VB.Menu mnuTV 
         Caption         =   "-"
         Index           =   9
      End
      Begin VB.Menu mnuTV 
         Caption         =   "Import Bookmarks"
         Index           =   10
      End
      Begin VB.Menu mnuTV 
         Caption         =   "Export Favorites"
         Index           =   11
      End
      Begin VB.Menu mnuTV 
         Caption         =   "-"
         Index           =   12
      End
      Begin VB.Menu mnuTV 
         Caption         =   "Refresh"
         Index           =   13
      End
   End
End
Attribute VB_Name = "frmBrow"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*********Copyright PSST Software 2001**********************
'Written by MrBobo - enjoy
'Please visit our website - www.psst.com.au

'Here is the third part of my Web Browser Tricks
'This time as a Web Browser(nearly)

'You need to reference Microsoft Internet Controls shdocvw.dll
'and Microsoft HTML Object Library mshtml.tbl

'What's here ?
'   - Favorites - a clone of Internet Explorer's Favorites menu
'     and a treeview, with access to IE's dialogs. The treeview has
'     a popup menu as an improvement over IE's.
'   - Autocomplete Address combo
'   - Menu's enabled/disabled by the Webbrowser
'   - Text resizing including identification of current size
'   - Progress bar in the Statusbar
'   - plus all the standard WebBrowser stuff

'To do - I'll leave it to you to add icons to the menu,
'   this will be easier than normal as we're already using
'   API to create the menu
'   - remove any inherrant bugs - this is only a demo !!

'I'm pretty sure all the code is mine - though using cut and paste
'may mean you recognize some procedures or routines, though I doubt it,
'- if so, thanks to the authors
'
'*************************************************************

'This form contains only standard WebBrowser stuff
'All the Favorites code is in a single re-usable module


Dim forwardenable As Boolean 'variables for Back/Forward
Dim backenable As Boolean
Dim cboselecting As Boolean 'used in controlling the cboAddress click event
Private Sub Brow_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
    Dim vStrPos As Long
    PB.Value = 0
    PB.Visible = SB.Visible
    PB.Move SB.Panels(2).Left + 30, SB.Top + 45, SB.Panels(2).Width - 60, SB.Height - 60
    If Brow.Busy = False Then
        If LCase(Left(URL, 4)) = "file" Then
            temp = URL
            temp = Replace(temp, "file:///", "")
            temp = Replace(temp, "/", "\")
            temp = Replace(temp, "%20", " ")
            cboAddress.Text = temp 'make local files appear readable
        Else
            cboAddress.Text = URL
        End If
        vStrPos = SendMessageByString&(cboAddress.hwnd, CB_FINDSTRING, 0, cboAddress.Text)
        If vStrPos = -1 Then
            cboAddress.AddItem cboAddress.Text 'add address if not there already
        End If
    End If
End Sub

Private Sub Brow_CommandStateChange(ByVal Command As Long, ByVal Enable As Boolean)
    On Error Resume Next
    Select Case Command 'identify Back/Forward state
        Case CSC_NAVIGATEFORWARD
                forwardenable = Enable
        Case CSC_NAVIGATEBACK
                backenable = Enable
    End Select
    mnuNavigate(0).Enabled = backenable
    mnuNavigate(1).Enabled = forwardenable
    If Command = -1 Then Exit Sub

End Sub

Private Sub Brow_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    Dim temp As String
    Dim vStrPos As Long
    If Brow.Document Is Nothing Then Exit Sub
    On Error Resume Next
    If Brow.Busy = False Then
        If LCase(Left(Brow.LocationURL, 4)) = "file" Then
            temp = Brow.LocationURL
            temp = Replace(temp, "file:///", "")
            temp = Replace(temp, "/", "\")
            temp = Replace(temp, "%20", " ")
            cboAddress.Text = temp 'make local files appear readable
        Else
            cboAddress.Text = Brow.LocationURL
        End If
        vStrPos = SendMessageByString&(cboAddress.hwnd, CB_FINDSTRINGEXACT, 0, cboAddress.Text)
        If vStrPos = -1 Then
            cboAddress.AddItem cboAddress.Text 'add address if not there already
        End If
        PB.Value = 0
        PB.Visible = False
        Me.Refresh
        If Brow.LocationName <> "about:blank" Then
            Me.Caption = Brow.LocationName + " - Bobo Browser"
        Else
            Me.Caption = "Bobo Browser" 'Update caption accordingly
        End If
    End If

End Sub

Private Sub Brow_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)
    On Error Resume Next
    If Not SB.Visible Then Exit Sub
    DoEvents
    If Progress = -1 Then PB.Value = 100
    If Progress > 0 And ProgressMax > 0 Then
        PB.Value = Progress * 100 / ProgressMax
        PB.Move SB.Panels(2).Left + 30, SB.Top + 45, SB.Panels(2).Width - 60, SB.Height - 60
        PB.Visible = True
    End If
    If PB.Value = 100 Then
        PB.Visible = False
    Else
        PB.Visible = True
        PB.Move SB.Panels(2).Left + 30, SB.Top + 45, SB.Panels(2).Width - 60, SB.Height - 60

    End If

End Sub

Private Sub Brow_StatusTextChange(ByVal Text As String)
    SB.Panels(1).Text = Text
End Sub

Private Sub cboAddress_Click()
    'only navigate if selected from dropdown
    If cboselecting Then cmdGo_Click
    cboselecting = False
End Sub

Private Sub cboAddress_DropDown()
    cboselecting = True 'enable navigation by clicking
End Sub

Private Sub cboAddress_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim z As Long, ll As Long, vStrPos As Long
    If KeyCode <> vbKeyBack Then
        If cboAddress.ListCount > 0 Then 'autocomplete routine
            z = SendMessageByString&(cboAddress.hwnd, CB_FINDSTRING, 0, cboAddress.Text)
            If z <> -1 And z <> cboAddress.ListIndex Then
                ll = Len(cboAddress.Text)
                cboAddress.ListIndex = z
                cboAddress.SelStart = ll
                cboAddress.SelLength = Len(cboAddress.Text) - ll
            End If
        End If
    End If
    If KeyCode = vbKeyReturn Then 'navigate if Return pressed
        Brow.Navigate cboAddress.Text
        vStrPos = SendMessageByString&(cboAddress.hwnd, CB_FINDSTRING, 0, cboAddress.Text)
        If vStrPos = -1 Then
            cboAddress.AddItem cboAddress.Text 'add address if not already there
            cboAddress.SelLength = 0
        End If
    End If
End Sub

Private Sub cmdGo_Click()
    Dim vStrPos As Long
    PicTop.SetFocus
    If Trim(cboAddress.Text) = "" Then Exit Sub
    Brow.Navigate cboAddress.Text 'navigate to address
    vStrPos = SendMessageByString&(cboAddress.hwnd, CB_FINDSTRINGEXACT, 0, cboAddress.Text)
    If vStrPos = -1 Then
        cboAddress.AddItem cboAddress.Text 'add address if not already there
    End If
End Sub
Private Sub Form_Load()
    Dim mycommand As String, v As Long
    'load up users favorites - see module
    'the treeview parameter is optional - if you only want the menu
    GetFaves Me, TV
    mnuFileOffline.Checked = Brow.Offline
    'Read settings from last session
    mnuViewStatusbar.Checked = GetSetting("PSST SOFTWARE\" + App.Title, "Settings", "StatusbarVisible", True)
    SB.Visible = mnuViewStatusbar.Checked
    mnuViewAddressbar.Checked = GetSetting("PSST SOFTWARE\" + App.Title, "Settings", "AddressbarVisible", True)
    PicTop.Visible = mnuViewAddressbar.Checked
    mnuViewFavorites.Checked = GetSetting("PSST SOFTWARE\" + App.Title, "Settings", "FavoritesVisible", False)
    PicLeft.Visible = mnuViewFavorites.Checked
    Me.Left = GetSetting("PSST SOFTWARE\" + App.Title, "Settings", "MainLeft", 1000)
    Me.Top = GetSetting("PSST SOFTWARE\" + App.Title, "Settings", "MainTop", 1000)
    Me.Width = GetSetting("PSST SOFTWARE\" + App.Title, "Settings", "MainWidth", 8685)
    Me.Height = GetSetting("PSST SOFTWARE\" + App.Title, "Settings", "MainHeight", 6330)
    Me.WindowState = 0
    Me.WindowState = GetSetting("PSST SOFTWARE\" + App.Title, "Settings", "WindowState", 2)
    DoEvents
    For v = 0 To 9 'load up addresses from registry
        temp = GetSetting("PSST SOFTWARE\" + App.Title, "Addresses", "Text" + Str(v))
        If temp <> "" Then
            vStrPos = SendMessageByString&(cboAddress.hwnd, CB_FINDSTRING, 0, temp)
            If vStrPos = -1 Then
                cboAddress.AddItem temp
            End If
        End If
    Next v
    If mycommand <> "" Then 'were we shelled ?
        Brow.Navigate mycommand 'yep
    Else
        Brow.Navigate2 "about:blank", 2 'open a blank page but dont add to travel log (back/forward history)
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim v As Integer, cnt As Long 'save settings to registry
    For v = cboAddress.ListCount - 1 To 0 Step -1
        If Len(Trim(cboAddress.List(v))) <> 0 Then
            SaveSetting "PSST SOFTWARE\" + App.Title, "Addresses", "Text" + Str(cnt), cboAddress.List(v)
            cnt = cnt + 1
        End If
        If cnt = 200 Then Exit For
    Next v
    If Me.WindowState = 2 Then
        SaveSetting "PSST SOFTWARE\" + App.Title, "Settings", "WindowState", 2
    Else
        SaveSetting "PSST SOFTWARE\" + App.Title, "Settings", "WindowState", 0
    End If
    If Me.WindowState <> 1 And Me.WindowState <> 2 Then
        SaveSetting "PSST SOFTWARE\" + App.Title, "Settings", "MainLeft", Me.Left
        SaveSetting "PSST SOFTWARE\" + App.Title, "Settings", "MainTop", Me.Top
        SaveSetting "PSST SOFTWARE\" + App.Title, "Settings", "MainWidth", Me.Width
        SaveSetting "PSST SOFTWARE\" + App.Title, "Settings", "MainHeight", Me.Height
    End If

End Sub

Private Sub Form_Resize()
    On Error Resume Next
    'I find it good practice to off-load resizing to
    'individual controls and in-built align functions
    If PicLeft.Visible Then
        PicRight.Width = Me.Width - PicLeft.Width - 150
    Else
        PicRight.Width = Me.Width - 150
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'There's only one form in this demo but...
    Dim frm As Form
    For Each frm In Forms