frmbrow.frm

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

        Unload frm
        Set frm = Nothing
    Next

End Sub

Private Sub mnuEdit_Click(Index As Integer)
    On Error Resume Next
    'These menu items will be enabled/disabled by
    'mnuEditBase_Click event
    Select Case Index
        Case 0
            Brow.ExecWB OLECMDID_UNDO, OLECMDEXECOPT_DODEFAULT
        Case 1
            Brow.ExecWB OLECMDID_REDO, OLECMDEXECOPT_DODEFAULT
        Case 3
            Brow.ExecWB OLECMDID_CUT, OLECMDEXECOPT_DODEFAULT
        Case 4
            Brow.ExecWB OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT
        Case 5
            Brow.ExecWB OLECMDID_PASTE, OLECMDEXECOPT_DODEFAULT
        Case 6
            Brow.ExecWB OLECMDID_DELETE, OLECMDEXECOPT_DODEFAULT
        Case 8
            Brow.ExecWB OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT
        Case 10
            Brow.SetFocus
            SendKeys "^f", True
        Case 11
            On Error Resume Next
            Brow.ExecWB OLECMDID_FIND, OLECMDEXECOPT_DONTPROMPTUSER
    End Select
End Sub


Private Sub mnuEditBase_Click()
    Dim mDoc As HTMLDocument
    Set mDoc = Brow.Document
    'enable/disable menus
    'some real power here - experiment with other calls
    mnuEdit(0).Enabled = mDoc.queryCommandEnabled("undo")
    mnuEdit(1).Enabled = mDoc.queryCommandEnabled("redo")
    mnuEdit(3).Enabled = mDoc.queryCommandEnabled("cut")
    mnuEdit(4).Enabled = mDoc.queryCommandEnabled("copy")
    mnuEdit(5).Enabled = mDoc.queryCommandEnabled("paste")
    mnuEdit(6).Enabled = mDoc.queryCommandEnabled("delete")
    mnuEdit(8).Enabled = mDoc.queryCommandEnabled("selectall")
End Sub

Private Sub mnuFileNew_Click()
    On Error Resume Next
    'you need to have compiled an exe for this to work
    Shell App.Path + "\" + App.EXEName + ".exe " + Brow.LocationURL
End Sub
Private Sub mnuFileOffline_Click()
    mnuFileOffline.Checked = Not mnuFileOffline.Checked
    Brow.Offline = mnuFileOffline.Checked
End Sub

Private Sub mnuFileOpen_Click()
    On Error GoTo woops
    With cmnDlg
        .Filter = "Web page (*.htm;*.html)|*.htm;*.html|Supported image formats|*.gif;*.tif;*.pcd;*.jpg;*.wmf;*.tga;*.jpeg;*.ras;*.png;*.eps;*.bmp;*.pcx|Text formats (*.txt;*.doc)|*.txt;*.doc|All files (*.*)|*.*"
        .Flags = 5
        .ShowOpen
        If Len(.FileName) = 0 Then Exit Sub
        Me.Refresh
        Brow.Navigate .FileName
     End With
woops:
End Sub

Private Sub mnuFilePageSetup_Click()
    On Error Resume Next
    Brow.ExecWB OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT
End Sub

Private Sub mnuFilePrint_Click()
    On Error Resume Next
    Brow.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT
End Sub

Private Sub mnuFileProperties_Click()
    On Error Resume Next
    Brow.ExecWB OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT
End Sub

Private Sub mnuFileSaveAs_Click()
    On Error GoTo woops
    If Brow.LocationURL = "" Then Exit Sub
    Brow.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_PROMPTUSER
woops:
End Sub

Private Sub mnuHelpAbout_Click()
    Dim temp As String
    temp = "This is the third of my 'Web Browser Tricks' submissions to PSC." + vbCrLf + _
    "It demonstrates some more advanced options than the first two." + vbCrLf + _
    "This is not a full blown Web Browser - simply a demo." + vbCrLf + _
    "As usual all illegal operations and bugs are provided free of charge." + vbCrLf + _
    "If you find this demo helpfull you might consider giving me a vote !" + vbCrLf + vbCrLf + _
    "By MrBobo - ㏄SST Software 2001"
    MsgBox temp, vbInformation, "PSST Software"
End Sub

Private Sub mnuNavigate_Click(Index As Integer)
    Select Case Index
        Case 0
            Brow.GoBack
        Case 1
            Brow.GoForward
        Case 2
            Brow.Stop
        Case 3
            Brow.Refresh
        Case 4
            Brow.GoHome
        Case 5
            Brow.GoSearch
    End Select
End Sub

Private Sub mnuText_Click(Index As Integer)
    Dim z As Long 'set font size
    On Error Resume Next
    For z = 0 To 4
        mnuText(z).Checked = False
    Next
    mnuText(Index).Checked = True
    Brow.ExecWB OLECMDID_ZOOM, OLECMDEXECOPT_DODEFAULT, CLng(Index)

End Sub

Private Sub mnuView_Click()
    'determine current font size
    'this function is usually missing in other examples I've seen
    Dim q
    Dim z As Long
    On Error Resume Next
    For z = 0 To 4
        mnuText(z).Checked = False
    Next
    Brow.ExecWB OLECMDID_ZOOM, OLECMDEXECOPT_DODEFAULT, , q
    mnuText(q).Checked = True

End Sub

Private Sub mnuViewAddressbar_Click()
    mnuViewAddressbar.Checked = Not mnuViewAddressbar.Checked
    PicTop.Visible = mnuViewAddressbar.Checked
    SaveSetting "PSST SOFTWARE\" + App.Title, "Settings", "AddressbarVisible", mnuViewAddressbar.Checked
    Form_Resize
End Sub

Private Sub mnuViewFavorites_Click()
    mnuViewFavorites.Checked = Not mnuViewFavorites.Checked
    PicLeft.Visible = mnuViewFavorites.Checked
    SaveSetting "PSST SOFTWARE\" + App.Title, "Settings", "FavoritesVisible", mnuViewFavorites.Checked
    Form_Resize
End Sub

Private Sub mnuViewInternetOptions_Click()
    'control panel applet
    Shell "rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl"
End Sub

Private Sub mnuViewStatusbar_Click()
    mnuViewStatusbar.Checked = Not mnuViewStatusbar.Checked
    SB.Visible = mnuViewStatusbar.Checked
    PB.Move SB.Panels(2).Left + 30, SB.Top + 45, SB.Panels(2).Width - 60, SB.Height - 60
    PB.Visible = SB.Visible 'hide progressbar accordingly
    SaveSetting "PSST SOFTWARE\" + App.Title, "Settings", "StatusbarVisible", mnuViewStatusbar.Checked
End Sub

Private Sub PicLeft_Resize()
    On Error Resume Next
    Toolbar1.Width = PicTVBase.ScaleWidth
    TV.Width = PicLeft.ScaleWidth
    TV.Height = PicLeft.ScaleHeight - TV.Top
End Sub
Private Sub PicTop_Resize()
    On Error Resume Next
    cmdGo.Left = PicTop.ScaleWidth - cmdGo.Width - 8
    cboAddress.Width = cmdGo.Left - cboAddress.Left - 4
End Sub
Private Sub PicRight_Resize()
    On Error Resume Next
    Brow.Width = PicRight.Width
    Brow.Height = PicRight.Height
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Index
        Case 1
            AddFaves 'see module
        Case 2
            OrgFaves 'see module
    End Select
End Sub
Private Sub mnuPopup_Click()
    If TV.SelectedItem Is Nothing Then TV.Nodes(1).Selected = True
    If TV.Nodes(1).Selected = True Then
        mnuTV(2).Enabled = False
        mnuTV(3).Enabled = False
        mnuTV(4).Enabled = False
    Else
        mnuTV(2).Enabled = True
        mnuTV(3).Enabled = True
        mnuTV(4).Enabled = True
    End If

End Sub
Private Sub mnuTV_Click(Index As Integer)
    Dim temp As String, temp1 As String, z As Long, IsDir As Boolean
    If Right(TV.SelectedItem.Key, 1) = "\" Then IsDir = True
    Select Case Index
        Case 0 'add favorite
            If mnuTV(0).Caption = "Add to Favorites..." Then
                AddFaves
                Exit Sub
            End If
            If IsDir Then
                temp = TV.SelectedItem.Key + ChangeExt(Brow.LocationName, "url")
            Else
                temp = TV.SelectedItem.parent.Key + ChangeExt(Brow.LocationName, "url")
            End If
            temp = SafeSave(temp) 'make sure we have a unique file name
            WriteINI temp, "InternetShortcut", "URL", Brow.LocationURL 'create an internet shortcut
            LockWindowUpdate TV.hwnd
            RefreshFaves 'reload tv and menu so we pick up changes
            LockWindowUpdate 0
        Case 2 'move favorite
            temp = BrowseForFolder(Me.hwnd)
            If temp = "" Then Exit Sub
            temp1 = TV.SelectedItem.Key
            If LCase(TV.SelectedItem.Key) = LCase(temp) Then Exit Sub
            If IsDir Then temp1 = Left(temp1, Len(temp1) - 1)
            temp = temp + "\" + mID$(temp1, InStrRev(temp1, "\") + 1)
            MoveFave temp1, temp ' see module
            LockWindowUpdate TV.hwnd
            RefreshFaves 'reload tv and menu so we pick up changes
            If IsDir Then temp = temp + "\"
            For z = 1 To TV.Nodes.Count
                If TV.Nodes(z).Key = temp Then
                    TV.Nodes(z).Expanded = True
                    TV.Nodes(z).Selected = True
                    TV.Nodes(z).EnsureVisible
                    Exit For
                End If
            Next
            LockWindowUpdate 0
        Case 3 'rename
            TV.StartLabelEdit
        Case 4 'delete
            temp1 = TV.SelectedItem.Key
            temp = TV.SelectedItem.parent.Key
            If IsDir Then temp1 = Left(temp1, Len(temp1) - 1)
            DeleteFave temp1 'see module
            LockWindowUpdate TV.hwnd
            RefreshFaves 'reload tv and menu so we pick up changes
            For z = 1 To TV.Nodes.Count
                If TV.Nodes(z).Key = temp Then
                    TV.Nodes(z).Expanded = True
                    TV.Nodes(z).Selected = True
                    TV.Nodes(z).EnsureVisible
                    Exit For
                End If
            Next
            LockWindowUpdate 0
        Case 5 'properties
            temp1 = TV.SelectedItem.Key
            If IsDir Then temp1 = Left(temp1, Len(temp1) - 1)
            GetPropDlg Me, temp1 'see module
        Case 7 'open folder in explorer
            If IsDir Then
                temp = TV.SelectedItem.Key
            Else
                temp = TV.SelectedItem.parent.Key
            End If
            Shell "explorer.exe " + temp, vbNormalFocus
        Case 8 'new folder
            If IsDir Then
                temp = TV.SelectedItem.Key
            Else
                temp = TV.SelectedItem.parent.Key
            End If
            LockWindowUpdate TV.hwnd
            MkDir SafeSave(temp + "New folder") 'get a unique name
            RefreshFaves
            temp = temp + safesavename + "\"
            For z = 1 To TV.Nodes.Count
                If TV.Nodes(z).Key = temp Then
                    TV.Nodes(z).Expanded = True
                    TV.Nodes(z).Selected = True
                    TV.Nodes(z).EnsureVisible
                    TV.SetFocus
                    TV.StartLabelEdit
                    Exit For
                End If
            Next
            LockWindowUpdate 0
        Case 10
            BrowDlg.ImportExportFavorites True, "" 'show IE dialog
        Case 11
            BrowDlg.ImportExportFavorites False, "" 'show IE dialog
        Case 13 'refresh
            LockWindowUpdate TV.hwnd
            RefreshFaves 'reload tv and menu so we pick up changes
            LockWindowUpdate 0
    End Select
End Sub
Private Sub TV_AfterLabelEdit(Cancel As Integer, NewString As String)
    Dim temp As String, temp1 As String, z As Long, IsDir As Boolean, ExtStr As String
    Dim isExpanded As Boolean
    temp = TV.SelectedItem.Key
    temp1 = TV.SelectedItem.Key
    If Right(temp, 1) = "\" Then
        IsDir = True
        isExpanded = TV.SelectedItem.Expanded
    Else
        ExtStr = ".url"
    End If
    If NewString = TV.SelectedItem.Text Then
        Cancel = 1
        Exit Sub
    End If
    LockWindowUpdate TV.hwnd
    If IsDir Then temp = Left(temp, Len(temp) - 1)
    RenameFave temp, PathOnly(temp) + "\" + NewString + ExtStr 'see module
    RefreshFaves
    If IsDir Then
        temp1 = PathOnly(temp) + "\" + NewString + "\"
    Else
        temp1 = PathOnly(temp) + "\" + NewString + ExtStr
    End If
    For z = 1 To TV.Nodes.Count
        If TV.Nodes(z).Key = temp1 Then
            If IsDir Then
                If isExpanded Then TV.Nodes(z).Expanded = True
            Else
                TV.Nodes(z).Expanded = True
            End If
            TV.Nodes(z).Selected = True
            TV.Nodes(z).EnsureVisible
            Exit For
        End If
    Next
    LockWindowUpdate 0
End Sub
Private Sub TV_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim fred As Node
    Dim temp As String
    Set fred = TV.HitTest(x, y)
    If fred Is Nothing Then Exit Sub
    If fred.Index = 1 Then Exit Sub
    Select Case Button
        Case 1
            If Right(fred.Key, 1) <> "\" Then
                If Not FileExists(fred.Key) Then Exit Sub
                temp = ReadINI(fred.Key, "InternetShortcut", "URL") 'get address from URL file
                If temp = "" Then Exit Sub
                If Brow.LocationURL <> temp Then Brow.Navigate temp 'navigate there
            End If
        Case 2
            If Right(fred.Key, 1) = "\" Then
                Me.PopupMenu mnuPopup 'show menu
            Else
                Me.PopupMenu mnuPopup
            End If
    End Select
End Sub