当前位置:编程学习 > VB >>

VB代码(网页)?

Private Sub Form_Load()

   Dim nURL As String

   WebBrowser1.Silent = True '禁止显示网页脚本对话框:脚本发生错误等

   Label1.UseMnemonic = False: Combo1.Text = ""

   

   moPage = moPage + 1 '记忆打开的窗口总个数,moPage 是模块变量

   If moPage = 1 Then  '是第一个网页,不是弹出的网页:检查首页设置

      nURL = Trim(Command)

If nURL = "" Then nURL = GetSetting(App.Title, "Opt", "Page1", " http://www.zhaoxi.net/")

      If nURL <> "" And Trim(nURL) = "" Then nURL = "about:blank"

      If nURL = " " Then nURL = "about:blank"

   End If

   

   Me.Tag = "Page" & moPage

   If nURL = "" Then nURL = "about:blank"

Combo1.AddItem " http://www.zhaoxi.net/"

   WebBrowser1.Navigate nURL

   

   '装载数组控件

   DoEvents

   KjAdd Command1, "前", "to_Last", "向前:上一网页"

   KjAdd Command1, "后", "to_Next", "向后:下一网页"

   KjAdd Command1, "-", "bar"

   KjAdd Command1, "源", "Source", "查看源文件"

   KjAdd Command1, "属", "NetOpt", "Internet 属性"

   KjAdd Command1, "主", "Page1", "更改主页"

   KjAdd Command1, "-", "bar"

   KjAdd Command1, "刷", "Refresh", "刷新"

   KjAdd Command1, "转到(&G)", "GoURL", "转到指定网页"

   

   '窗口为屏幕的 4/5 大小,并居中

   On Error Resume Next

   Me.Move Screen.Width * 0.1, Screen.Height * 0.1, Screen.Width * 0.8, Screen.Height * 0.8

End Sub

 

Private Sub NetOpt()

   On Error Resume Next

   Shell "Control.exe Inetcpl.cpl", 1 '打开:Internet 属性

End Sub

 

Private Sub Form_Resize()

  '自动设置控件位置和大小

   Dim I As Long, L As Single, T As Single, H As Single, H1 As Single, W As Single

 

   H1 = Combo1.Height * 1.2: L = H1 * 0.3: T = L

   L = H1 * 0.2

   For I = 0 To Command1.Count - 1

      If Command1(I).Caption = "-" Then '按钮分组

         W = H1 * 0.5: Command1(I).Visible = False

      Else

         W = Me.TextWidth(Command1(I).Caption & "ab")

         Command1(I).Move L, T, W, H1: Command1(I).Visible = True

      End If

      L = L + W + 3

   Next

   

   T = T + H1 * 0.1 + Command1(0).Height

   I = Command1.Count - 1

   Command1(I).Move 0, T

   

   L = Command1(I).Left + Command1(I).Width

   W = Me.ScaleWidth - L

   If W > 0 Then Combo1.Move L, T + H1 * 0.1, W

   

   T = T + Combo1.Height * 1.2: H = Me.ScaleHeight - T - Combo1.Height

   If H > 0 Then WebBrowser1.Move 0, T, Me.ScaleWidth, H

   

   T = T + WebBrowser1.Height + H1 * 0.1

   Label1.Move H1 * 0.1, T, Screen.Width, Combo1.Height

End Sub

 

Private Function KjAdd(Kj, nCap As String, Optional nTag As String, Optional nNote As String) As Long

   '为数组控件添加一个成员,返回新添加的成员序号

   Dim I As Long

   I = Kj.Count - 1

   If Kj(I).Tag <> "" Then I = I + 1: Load Kj(I)

   On Error Resume Next

   Kj(I).Checked = False

   Kj(I).Caption = nCap

   Kj(I).Tag = nTag

   Kj(I).ToolTipText = nNote

   Kj(I).Visible = True

   KjAdd = I

End Function

 

Private Sub Command1_Click(Index As Integer)

   '工具栏按钮命令

   nStr = LCase(Command1(Index).Tag)

   Select Case nStr

   Case LCase("to_Last"): On Error Resume Next: WebBrowser1.GoBack    '向前

   Case LCase("to_Next"): On Error Resume Next: WebBrowser1.GoForward '向后

   Case LCase("Source"):  Call ViewSource                             '查看源文件

   Case LCase("GoURL"):   Call Combo1_Click                           '转到指定网页

   Case LCase("Refresh"): WebBrowser1.Refresh                         '刷新

   Case LCase("NetOpt"):  Call NetOpt                                 'Internet 属性

   Case LCase("Page1"):   Call Page1                                  '更改主页

   End Select

End Sub

 

Private Sub Page1()

   '更改主页

   Dim nStr As String

   nStr = "当前主页是:" & vbCrLf & GetSetting(App.Title, "Opt", "Page1", "about:blank")

   nStr = nStr & vbCrLf & vbCrLf & "输入空格表示使用空白页。请输入新的主页:"

   nStr = InputBox(nStr, "更改主页", Me.WebBrowser1.LocationURL)

   If nStr <> "" Then SaveSetting App.Title, "Opt", "Page1", nStr

End Sub

 

Private Sub ViewSource()

   '用 Form2 查看源文件

   Dim NewForm As New Form2, nTag As String, nStr As String, Obj1

   

   NewForm.Caption = "查看源文件 - " & WebBrowser1.LocationURL

   NewForm.Show

   

   On Error Resume Next

   For I = 0 To WebBrowser1.Document.All.length - 1

      Set Obj1 = WebBrowser1.Document.All(I)

      nTag = ""

      nTag = Obj1.tagName

      If LCase(nTag) = "html" Then

         NewForm.Text1.Text = nStr & Obj1.outerHTML

         Exit Sub

      Else

         nStr = nStr & Obj1.outerHTML & vbCrLf

      End If

   Next

End Sub

 

Private Sub WebBrowser1_NavigateComplete2(ByVal pDisp As Object, URL As Variant)

   '将浏览网页的地址添加到 Combo1

   Dim nStr As String

   

   nStr = WebBrowser1.LocationURL

   Combo1.Text = nStr

   

   If Combo1.ListCount > 0 Then

      If LCase(nStr) = LCase(Combo1.List(0)) Then Exit Sub

      If LCase(nStr) = LCase(Combo1.List(0)) & "/" Then Exit Sub

   End If

   

   If LCase(nStr) = "about:blank" Or nStr = "" Then Exit Sub

   Combo1.AddItem nStr, 0

End Sub

 

Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)

   '不用 IE 而用自己的程序弹出新窗口

   Dim NewForm As New Form1

 

   Set ppDisp = NewForm.WebBrowser1.object

   NewForm.Show

End Sub

 

Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)

   '用户在下拉列表框输入网址后,按回车转到指定网页

   If KeyCode = 13 Then Call Combo1_Click

End Sub

 

追问:Private Sub Combo1_Click()

   '用户单击下拉列表框选择网址后,转到指定网页

   Dim nStr As String

   nStr = Trim(Combo1.Text)

   If nStr <> "" Then WebBrowser1.Navigate nStr

End Sub

 

Private Sub WebBrowser1_StatusTextChange(ByVal Text As String)

   '在窗口下面显示网页状态

   If Text = "" Then Label1.Caption = "就绪" Else Label1.Caption = Text

End Sub

 

Private Sub WebBrowser1_TitleChange(ByVal Text As String)

   '在标题栏显示网页标题

   Me.Caption = "我的浏览器 - " & Text

End Sub

 

' '===============以下是窗体 Form2 代码,此窗体用于查看网页源文件

'需在窗体放置一个控件:Text1,并将属性 MultiLine 设置为 True,ScrollBars 设置为 2

Private Sub Form_Load()

   '窗口为屏幕的 3/5 大小,并居中

   On Error Resume Next

   Move Screen.Width * 0.2, Screen.Height * 0.2, Screen.Width * 0.6, Screen.Height * 0.6

End Sub

 

Private Sub Form_Resize()

   On Error Resume Next

   Text1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight

End Sub

答案:
Private Sub Combo1_Click()
Dim nUrl As String
nUrl = Combo1.Text

'
If nUrl = "" Then nUrl = GetSetting(App.Title, "Opt", "Page1", " http://www.zhaoxi.net/")

      If nUrl <> "" And Trim(nUrl) = "" Then nUrl = "about:blank"

      If nUrl = " " Then nUrl = "about:blank"
WebBrowser1.Navigate nUrl
   
End Sub

Private Sub Form_Load()

   Dim nUrl As String

   WebBrowser1.Silent = True '禁止显示网页脚本对话框:脚本发生错误等

   Label1.UseMnemonic = False: Combo1.Text = ""

   

   moPage = moPage + 1 '记忆打开的窗口总个数,moPage 是模块变量

   If moPage = 1 Then  '是第一个网页,不是弹出的网页:检查首页设置

      nUrl = Trim(Command)

If nUrl = "" Then nUrl = GetSetting(App.Title, "Opt", "Page1", " http://www.zhaoxi.net/")

      If nUrl <> "" And Trim(nUrl) = "" Then nUrl = "about:blank"

      If nUrl = " " Then nUrl = "about:blank"

   End If

   

   Me.Tag = "Page" & moPage

   If nUrl = "" Then nUrl = "about:blank"

Combo1.AddItem " http://www.zhaoxi.net/"

   WebBrowser1.Navigate nUrl

   

   '装载数组控件

   DoEvents

   KjAdd Command1, "前", "to_Last", "向前:上一网页"

   KjAdd Command1, "后", "to_Next", "向后:下一网页"

   KjAdd Command1, "-", "bar"

   KjAdd Command1, "源", "Source", "查看源文件"

   KjAdd Command1, "属", "NetOpt", "Internet 属性"

   KjAdd Command1, "主", "Page1", "更改主页"

   KjAdd Command1, "-", "bar"

   KjAdd Command1, "刷", "Refresh", "刷新"

   KjAdd Command1, "转到(&G)", "GoURL", "转到指定网页"

   

   '窗口为屏幕的 4/5 大小,并居中

   On Error Resume Next

   Me.Move Screen.Width * 0.1, Screen.Height * 0.1, Screen.Width * 0.8, Screen.Height * 0.8

End Sub

 

Private Sub NetOpt()

   On Error Resume Next

   Shell "Control.exe Inetcpl.cpl", 1 '打开:Internet 属性

End Sub

 

Private Sub Form_Resize()

  '自动设置控件位置和大小

   Dim I As Long, L As Single, T As Single, H As Single, H1 As Single, W As Single

 

   H1 = Combo1.Height * 1.2: L = H1 * 0.3: T = L

   L = H1 * 0.2

   For I = 0 To Command1.Count - 1

      If Command1(I).Caption = "-" Then '按钮分组

         W = H1 * 0.5: Command1(I).Visible = False

      Else

         W = Me.TextWidth(Command1(I).Caption & "ab")

         Command1(I).Move L, T, W, H1: Command1(I).Visible = True

      End If

      L = L + W + 3

   Next

   

   T = T + H1 * 0.1 + Command1(0).Height

   I = Command1.Count - 1

   Command1(I).Move 0, T

   

   L = Command1(I).Left + Command1(I).Width

   W = Me.ScaleWidth - L

   If W > 0 Then Combo1.Move L, T + H1 * 0.1, W

   

   T = T + Combo1.Height * 1.2: H = Me.ScaleHeight - T - Combo1.Height

   If H > 0 Then WebBrowser1.Move 0, T, Me.ScaleWidth, H

   

   T = T + WebBrowser1.Height + H1 * 0.1

   Label1.Move H1 * 0.1, T, Screen.Width, Combo1.Height

End Sub

 

Private Function KjAdd(Kj, nCap As String, Optional nTag As String, Optional nNote As String) As Long

   '为数组控件添加一个成员,返回新添加的成员序号

   Dim I As Long

   I = Kj.Count - 1

   If Kj(I).Tag <> "" Then I = I + 1: Load Kj(I)

   On Error Resume Next

   Kj(I).Checked = False

   Kj(I).Caption = nCap

   Kj(I).Tag = nTag

   Kj(I).ToolTipText = nNote

   Kj(I).Visible = True

   KjAdd = I

End Function

 

Private Sub Command1_Click(Index As Integer)

   '工具栏按钮命令

   nStr = LCase(Command1(Index).Tag)

   Select Case nStr

   Case LCase("to_Last"): On Error Resume Next: WebBrowser1.GoBack    '向前

   Case LCase("to_Next"): On Error Resume Next: WebBrowser1.GoForward '向后

   Case LCase("Source"):  Call ViewSource                             '查看源文件

  ' Case LCase("GoURL"):   Call Combo1_Click                           '转到指定网页

   Case LCase("Refresh"): WebBrowser1.Refresh                         '刷新

   Case LCase("NetOpt"):  Call NetOpt                                 'Internet 属性

   Case LCase("Page1"):   Call Page1                                  '更改主页

   End Select

End Sub

 

Private Sub Page1()

   '更改主页

   Dim nStr As String

   nStr = "当前主页是:" & vbCrLf & GetSetting(App.Title, "Opt", "Page1", "about:blank")

   nStr = nStr & vbCrLf & vbCrLf & "输入空格表示使用空白页。请输入新的主页:"

   nStr = InputBox(nStr, "更改主页", Me.WebBrowser1.LocationURL)

   If nStr <> "" Then SaveSetting App.Title, "Opt", "Page1", nStr

End Sub

 

Private Sub ViewSource()

   '用 Form2 查看源文件

   Dim NewForm As New Form2, nTag As String, nStr As String, Obj1

   

   NewForm.Caption = "查看源文件 - " & WebBrowser1.LocationURL

   NewForm.Show

   

   On Error Resume Next

   For I = 0 To WebBrowser1.Document.All.Length - 1

      Set Obj1 = WebBrowser1.Document.All(I)

      nTag = ""

      nTag = Obj1.tagName

      If LCase(nTag) = "html" Then

         NewForm.Text1.Text = nStr & Obj1.outerHTML

         Exit Sub

      Else

         nStr = nStr & Obj1.outerHTML &

上一个:VB的关键字极含义?
下一个:一个VB程序问题

CopyRight © 2012 站长网 编程知识问答 www.zzzyk.com All Rights Reserved
部份技术文章来自网络,