| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 945 人关注过本帖
标题:技术分享:简单VB的浏览器,但访问PHP网站内页时出错;单独用IE却可正常打开 ...
只看楼主 加入收藏
新菜鸟一位
Rank: 1
等 级:新手上路
帖 子:2
专家分:0
注 册:2014-2-10
收藏
 问题点数:0 回复次数:0 
技术分享:简单VB的浏览器,但访问PHP网站内页时出错;单独用IE却可正常打开。请各位大神帮助啊!!!
我是个新手菜鸟,请大神位,帮教导一下。

    设计了一个简单的浏览器,使用WebBrowse 控件的 event 对象,可以捕获 WebBrowser 众多的鼠标和键盘事件,如鼠标坐标、按下了键盘哪个键,以及键盘 Ctrl、Alt、Shift 键的状态、当前网页元素的ID、索引等等。接收到的 WebBrowse 事件最终汇集到 Form1 的 PageEvents 过程中,修改此过程代码,可以获取不同的页面信息。如果将 Cancel 设置为 True,可以拦截页面某些事件,如 Click、DblClick、KeyPress,可实现到禁止网页跳转、禁止输入等功能。
实现的功能:
  一.自动将浏览过的网页地址添加到地址栏列表框中
  二.按下 Alt 键在页面中单击,可将鼠标处的网页元素、鼠标位置等信息复制到剪贴板中。
  三.在“转到”按钮上单击鼠标左键:跳转到指定网站。 单击右键:显示或隐藏内嵌网页列表
  四.单击内嵌网页列表某条目,可用新窗口打开这个内嵌网页。
  五.单击窗口下面的状态栏文字上单击,可切换信息显示方式:详细信息或简单信息。
缺点:
    1、打开如PHP内链接。显示空白页。不知为什么?
    可以调试通过,包含两个窗体:Form1 和 Form2,一个模块:Module1
' ' '在“工程/部件”对话框中勾选:Microsoft Internet Controls
' ' '在“工程/引用”对话框中勾选:Microsoft HTML Object Library
'然后在窗体放置 5 个控件:WebBrowser1、Label1、Command1、Combo1、Combo2


===FORM1窗体代码如下===

Private WithEvents V1 As WebBrowser_V1
Public ctDocS As Long, ctJian As Boolean
Public Old_Cookies As String, Old_Cache As String, Old_Win_title  As String
'----常数定义和API申明
     Private Const HKEY_CLASSES_ROOT = &H80000000  '主键
     Private Const HKEY_CURRENT_USER = &H80000001  '主键
     Private Const STANDARD_RIGHTS_ALL = &H1F0000
     Private Const KEY_ENUMERATE_SUB_KEYS = &H8
     Private Const KEY_SET_VALUE = &H2
     Private Const KEY_CREATE_SUB_KEY = &H4
     Private Const KEY_QUERY_VALUE = &H1
     Private Const KEY_NOTIFY = &H10
     Private Const KEY_CREATE_LINK = &H20
     Private Const SYNCHRONIZE = &H100000
     Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
     Private Const REG_MULTI_SZ = 7
     Private Const ERROR_SUCCESS = 0&
     Private Const READ_CONTROL = &H20000
     Private Const REG_SZ = 1
     Private Const REG_DWORD = 4
     Private Const REG_EXPAND_SZ = 2
     Private Const REG_BINARY = 3
     Private Const REG_DWORD_BIG_ENDIAN = 5
     Private Const REG_DWORD_LITTLE_ENDIAN = 4
     Private Const REG_NONE = 0
     Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
     'Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByRef phkResult As Long) As Long
     Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
     Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
     Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
     Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
     
     Private Declare Function GetRegistryValue Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
         
     
   
Private Sub Form_Load()
'=====以下为测试注册表读写定义
     'Dim hKey, hhkey As Long '主键的句柄
     'Dim lpData As String '查询得到的键值
     'Dim SizeOfData As Long '键值的长度
     'Dim ValueType As Long '键值的类型
     'SizeOfData = 150
     'Dim return_OpenKey As Long '函数调用的返回值
     'Dim PriKey As String '主键
     'Dim KeyValue1, KeyValue2 As String '键值名称
     'Dim Cookies_Newpath, Cache_Newpath As String
'======
'======以下为简单的读写测试
     'Cookies_Newpath = "D:\cookies"
     'Cache_Newpath = "D:\Ie_regedit_test\Temporary Internet Files"
     
     
     'Dim wshshell As New IWshRuntimeLibrary.wshshell
     
     'Dim mypcname As String
     
     ' Old_Cookies = wshshell.RegRead("HKEY_CURRENT_USER\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\EXPLORER\User Shell Folders\Cookies")
     ' Old_Cache = wshshell.RegRead("HKEY_CURRENT_USER\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\EXPLORER\User Shell Folders\Cache")
     ' Old_Win_title = wshshell.RegRead("HKEY_CURRENT_USER\SOFTWARE\MICROSOFT\INTERNET EXPLORER\MAIN\Window Title")
 
     '可以向注册表中写键值 wshshell.RegWrite "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\ComputerName\ActiveComputerName\Computername", mypcname
 '======以下为简单的读写测试
     ''tSet = RegOpenKeyEx(HKEY_CURRENT_USER, "SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\EXPLORER\User Shell Folders", "Cookies", hKey)
     
     ''tSet1 = RegOpenKeyEx(HKEY_CURRENT_USER, "SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\EXPLORER\User Shell Folders", "Cache")

     ''tSet2 = RegOpenKeyEx(HKEY_CURRENT_USER, "SOFTWARE\MICROSOFT\INTERNET EXPLORER\MAIN", "Window Title", hKey)

     'PriKey = "北信BITI\People" '主键
     'KeyValue1 = "教授" '键值名称
     'KeyValue2 = "学生" '键值名称
  
 '==============
 'return_OpenKey = RegOpenKeyEx(HKEY_CURRENT_USER, "", 0, KEY_ALL_ACCESS, hKey)
   
 '下面的函数RegCreateKey建立一个主键,如此键已存在,则打开它
 'If RegCreateKey(hKey, PriKey, hKey) <> ERROR_SUCCESS Then
 '   MsgBox "create " & PriKey & "Failed"
 '   Exit Sub
 'End If
'Dim KeyData As String '键值
'KeyData = "500"

    '下面的函数RegSetValueEx给指定的键值名称赋键值

'If RegSetValueEx(hKey, KeyValue1, 0&, REG_SZ, ByVal KeyData, Len(KeyData) + 1) <> ERROR_SUCCESS Then
'     MsgBox "SetValue " & KeyValue1 & "Failed "
'     Exit Sub
'     End If
'     KeyData = "15020"

'    '下面的函数RegSetValueEx给指定的键值名称"学生" 赋键值为"15020"

'If RegSetValueEx(hKey, KeyValue2, 0&, REG_SZ, ByVal KeyData, Len(KeyData) + 1) <> ERROR_SUCCESS Then
'MsgBox "SetValue " & KeyValue2 & "Failed "
'Exit Sub
'End If
   
'return_OpenKey = RegQueryValueEx(hKey, KeyValue1, 0&, REG_SZ, 0&, SizeOfData)
'lpData = String(SizeOfData + 1, " ")

'    '下面的函数RegQueryValueEx检索指定键值名称的键值和键值类型

'If RegQueryValueEx(hKey, KeyValue1, 0&, REG_SZ, ByVal lpData, SizeOfData) <> ERROR_SUCCESS Then
'MsgBox "Query " & KeyValue1 & "Failed"
'End If
'RegCloseKey (hKey) '释放主键的句柄
'=============以下为注册表读写测试


moPage = moPage + 1: Me.Tag = "Win" & moPage '计数打开的窗口个数
   Label1.BorderStyle = 0: Label1.UseMnemonic = False
   Label1.AutoSize = True: Label1.Caption = "就绪"
   Command1.Caption = "转到:"
   Command1.ToolTipText = "单击鼠标左键:跳转到指定网站。 单击右键:显示或隐藏内嵌网页列表"
   Combo1.Text = "": Combo2.Text = " 无内嵌网页"

   WebBrowser1.Navigate "about:blank" '设置为空白页
   DoEvents
   Set V1 = WebBrowser1.Object
   If moPage = 1 Then OpenURL "http://www.baidu.com/" '设置显示的首页
   Me.Move Screen.Width * 0.1, Screen.Height * 0.1, Screen.Width * 0.8, Screen.Height * 0.8

End Sub

Private Sub Form_Resize()
   Dim H1 As Long, H As Long, T As Long, W As Long
   On Error Resume Next
   
   H1 = Me.TextHeight("A")
   
   On Error Resume Next
   Command1.Move H1 * 0.25, H1 * 0.2, H1 * 4, H1 * 2
   W = Command1.Left + Command1.Width + H1 * 0.2
   Combo1.Move W, H1 * 0.5, Me.ScaleWidth - W - H1 * 0.2
   
   If ctJian Then
      H = H1 * 1.3
      Label1.ToolTipText = "单击切换信息显示方式: 详细信息 √ 简单信息  按着 Alt 键在页面中单击,可将信息复制到剪贴板中。"
   Else
      H = H1 * 4.2
      Label1.ToolTipText = "单击切换信息显示方式:√ 详细信息 简单信息  按着 Alt 键在页面中单击,可将信息复制到剪贴板中。"
   End If
   Label1.Move H1 * 0.5, Me.ScaleHeight - H '信息栏
   
   T = Command1.Top + Command1.Height + H1 * 0.2
   If Combo2.Visible Then
      Combo2.Move 0, T, Me.ScaleWidth
      T = Combo2.Top + Combo2.Height + H1 * 0.2
   End If
   H = Label1.Top - T - H1 * 0.2
   WebBrowser1.Move 0, T, Me.ScaleWidth, H
End Sub

Private Sub Form_Unload(Cancel As Integer)
   LoadDocForm Me, , , , , True '卸载 由本窗体添加的 所有事件捕捉窗体
End Sub

Private Sub WebBrowser1_StatusTextChange(ByVal Text As String)
 If Text = "" Then Text = "就绪"
   If ctJian Then Label1.Caption = Text
   Label1.Tag = Text
End Sub

Private Sub V1_NewWindow(ByVal URL As String, ByVal Flags As Long, ByVal TargetFrameName As String, PostData As Variant, ByVal Headers As String, Processed As Boolean)
   '注意:WebBrowser1_NewWindow2 过程中不能放任何代码,否则不会触发此事件
   Processed = True '阻止弹出 IE
   NewWindow URL    '用自己的程序显示弹出窗口

End Sub
Private Sub NewWindow(ByVal URL As String)
   '用自己的程序显示弹出窗口
   Dim NewWin As New Form1 '注意主窗口名称,我用的是默认名称:Form1
   NewWin.ctJian = ctJian
    = Combo2.Visible
   NewWin.Show
   NewWin.WebBrowser1.Navigate URL '用自己的程序显示弹出窗口
End Sub
Private Sub WebBrowser1_TitleChange(ByVal Text As String)
   Me.Caption = "我的浏览器 - " & Text
End Sub
Private Sub WebBrowser1_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
   Dim DisURL As String, S As Long, nStr As String, IsMain As Boolean
   Dim Doc As MSHTML.HTMLDocument, LocURL As String
   
   DisURL = URL: LocURL = WebBrowser1.LocationURL
   AddURL LocURL  '将已浏览网页的地址添加到 Combo1
   If LCase(Left(LocURL, 5)) = "file:" Then
      If Mid(DisURL, 2, 1) = ":" Then DisURL = "file:///" & Replace(DisURL, "\", "/")
   End If

   IsMain = LCase(DisURL) = LCase(LocURL)      '是否主网页
   If IsMain Then LoadDocForm Me, , , , , True '卸载 由本窗体添加的 所有事件捕捉窗体
  
   S = InStr(DisURL, ":")
   If S > 0 Then nStr = Trim(Left(DisURL, S)) '得到 “:”前的字符
   If nStr = "about:" Then Exit Sub
   'If nStr = "about:" Or nStr = "javascript:" Then Exit Sub
   LoadDocForm Me, pDisp.Document, IsMain '添加一个 捕捉网页事件的隐式窗体
End Sub
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
   AddIFrameDoc pDisp.Document '为内嵌框架 添加捕捉窗口
   AddToCombo Me               '将内嵌网页和框架名称添加到 Combo2
   
   'If Not WebBrowser1.Busy Then '判断是否下载完
   '   Text1.Text = "  当前 Cookie Is:" + WebBrowser1.Document.cookie
   '   DoEvents
   'End If
   'WebBrowser1.Document.cookie = Text1.Text
End Sub
Private Sub WebBrowser1_DownloadBegin()
WebBrowser1.Silent = True
End Sub
Private Sub WebBrowser1_DownloadComplete()
WebBrowser1.Silent = True
End Sub

Private Sub AddIFrameDoc(Doc As MSHTML.HTMLDocument)

   '为内嵌框架 添加捕捉窗口
   Dim I As Long, S As Long, nIFRAME
   
   On Error Resume Next
   Set nIFRAME = Doc.getElementsByTagName("IFRAME")
   S = nIFRAME.length
   For I = 0 To S - 1 '为每一个 IFRAME 添加一个事件捕捉窗口
       Set Doc = Nothing
       Set Doc = nIFRAME(I).contentWindow.Document '可能没有加载完毕
       If Not (Doc Is Nothing) Then LoadDocForm Me, Doc, , nIFRAME(I).Src, True
   Next
End Sub


Private Sub Combo2_Click()
   Dim URL As String, S As Long
   
   URL = Combo2.Text
   S = InStr(URL, " ■ ")
   If S > 0 Then URL = Mid(URL, S + 3)
   NewWindow URL '用新窗口显示内嵌网页
End Sub

Private Sub AddURL(nURL As String)
   '将已浏览网页的地址添加到 Combo1
   Dim I As Long
   
   If LCase(nURL) = "about:blank" Then Exit Sub
   For I = 0 To Combo1.ListCount - 1
      If LCase(Combo1.List(I)) = LCase(nURL) Then GoTo ShowURL1
   Next
   Combo1.AddItem nURL, 0
ShowURL1:
   Combo1.Text = nURL
End Sub

Private Sub Command1_Click()
   OpenURL Combo1.Text
End Sub
Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
   If Button <> 2 Then Exit Sub
   Combo2.Visible = Not Combo2.Visible '显示或隐藏内嵌网页列表
   Call Form_Resize
End Sub

Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   ctJian = Not ctJian '切换信息显示方式: 详细/简单
   Call Form_Resize
   If ctJian Then Label1.Caption = Label1.Tag Else Label1.Caption = "在页面移动、单击鼠标,可显示详细信息"
End Sub

Private Sub Combo1_Click()
   OpenURL Combo1.Text
End Sub
Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
   If KeyCode = 13 Then OpenURL Combo1.Text
End Sub

Private Sub OpenURL(URL As String)
   WebBrowser1.Navigate Trim(URL)
End Sub



Public Sub PageEvents(EventName As String, Events As IHTMLEventObj, Elem As IHTMLElement, _
   Doc As MSHTML.HTMLDocument, Src As String, DocTag As String, Cancel As Boolean)
   '接收网页事件,参数说明:
   'EventName:事件名称,如:MouseDown、MouseMove 等
   'Events:   事件的参数对象,如鼠标的坐标、键盘的键代码等
   'Elem:     触发事件的网页元素
   'Doc:      触发事件的网页
   'Src:       如果触发事件的源是内嵌框架,Src 参数不会为空
   'DocTag:   触发事件的隐式窗体标记,实际就是 Form2 的不同实例
   'Cancel:   通过将此参数设置为 True,可以拦截某些事件,如 Click、DblClick、KeyPress
   Dim nStr As String, nTag As String, Str1 As String, UpStr As String
   
   '事件名称和鼠标的坐标
   nStr = "Name=" & EventName & " X=" & Events.clientX & " Y=" & Events.clientY
    '按下了鼠标哪个键,键盘的键代码
   nStr = nStr & " Button=" & Events.Button & " KeyCode=" & Events.KeyCode
   '键盘 Ctrl,Alt,Shift 的状态
   nStr = nStr & " Ctrl=" & Events.ctrlKey & " Alt=" & Events.altKey & " Shift=" & Events.shiftKey
   
   On Error Resume Next
   nTag = UCase(Elem.tagName)
   nStr = nStr & vbCrLf & "元素=" & nTag & " ID=" & Elem.Id & " 索引=" & Elem.sourceIndex
  
   Str1 = Elem.innerText
   If Len(Str1) > 40 Then Str1 = Left(Str1, 40) & "…"
   Str1 = Replace(Str1, vbCrLf, "┓")
   
   If nTag = "INPUT" Then Str1 = Elem.Value
   If Str1 <> "" Then Str1 = "【" & Str1 & "】"
   If nTag = "A" Then Str1 = Str1 & vbCrLf & " 链接=" & Elem.href
   If nTag = "IMG" Then Str1 = Str1 & vbCrLf & " 图片=" & Elem.Src

   If Not ctJian Then
      If Src = "" Then
         nStr = "网页=" & DocTag & " 地址=" & Doc.URL & vbCrLf & nStr
      Else
         nStr = "网页=" & DocTag & " 框架=" & Src & vbCrLf & nStr
      End If
      Label1.Caption = nStr & Str1
   End If
   
   If Events.ctrlKey And Events.altKey And Events.KeyCode = vbKeyF Then 'Ctrl+Alt+F
      Clipboard.Clear: Clipboard.SetText Label1.Caption '将信息复制到剪贴板
      MsgBox "复制信息到剪贴板,成功。", vbInformation, "复制信息"
   End If

   If EventName = "Click" And Events.altKey Then
      Cancel = True '拦截鼠标单击事件,阻止网页跳转
      Clipboard.Clear: Clipboard.SetText Label1.Caption '将信息复制到剪贴板
      MsgBox "复制信息到剪贴板,成功。", vbInformation, "复制信息"
   End If
End Sub

Private Sub WebBrowser1_Click()

End Sub
======
===FORM2窗体代码如下====
Private WithEvents ctDoc As MSHTML.HTMLDocument
Dim ctFormSource As Form, ctURL As String
Dim ctSrc As String, ctIsIFrame As Boolean, ctIsMain As Boolean
Public Sub SetDoc(nFormSource As Form, DocTag As String, Doc As MSHTML.HTMLDocument, _
   Optional Src As String, Optional IsIFrame As Boolean, Optional IsMain As Boolean)
   Set ctFormSource = nFormSource '网页所在的主窗口
   Set ctDoc = Doc '网页 Document 对象
   ctURL = Doc.URL '网页地址
   Me.Tag = DocTag '捕捉窗口标记
   ctSrc = Src     '框架 scr 属性,当 IsIFrame=True 时有效
   ctIsIFrame = IsIFrame '是否是框架
   ctIsMain = IsMain     '是否是主页面(非内嵌网页或框架)
End Sub

Public Sub GetDoc(Doc As MSHTML.HTMLDocument, URL As String, Src As String, IsIFrame As Boolean, IsMain As Boolean)
   Set Doc = ctDoc
   Src = ctSrc: URL = ctURL: IsIFrame = ctIsIFrame: IsMain = ctIsMain
End Sub

Public Function GetSrc() As String
   GetSrc = ctSrc
End Function

Private Function ctDoc_onclick() As Boolean
   ctDoc_onclick = EventsHTML(ctFormSource, ctDoc, ctSrc, Me.Tag, "Click") '单击
End Function
Private Sub ctDoc_onmousedown()
   EventsHTML ctFormSource, ctDoc, ctSrc, Me.Tag, "MouseDown"  '按下鼠标
End Sub
Private Sub ctDoc_onmousemove()
   EventsHTML ctFormSource, ctDoc, ctSrc, Me.Tag, "MouseMove"  '移动鼠标
End Sub
Private Sub ctDoc_onmouseup()
   EventsHTML ctFormSource, ctDoc, ctSrc, Me.Tag, "MouseUp"  '抬起鼠标
End Sub
Private Function ctDoc_ondblclick() As Boolean
   ctDoc_ondblclick = EventsHTML(ctFormSource, ctDoc, ctSrc, Me.Tag, "DblClick")  '双击
End Function

Private Sub ctDoc_onkeydown()
   EventsHTML ctFormSource, ctDoc, ctSrc, Me.Tag, "KeyDown"  '按下键
End Sub
Private Function ctDoc_onkeypress() As Boolean
   ctDoc_onkeypress = EventsHTML(ctFormSource, ctDoc, ctSrc, Me.Tag, "KeyPress")  '击键
End Function
Private Sub ctDoc_onkeyup()
   EventsHTML ctFormSource, ctDoc, ctSrc, Me.Tag, "KeyUp"  '放开键
End Sub

'Private Sub ctDoc_onfocusin()
'   EventsHTML ctFormSource, ctDoc, ctSrc, Me.Tag, "GotFocus" '获得焦点
'End Sub
'Private Sub ctDoc_onfocusout()
'   EventsHTML ctFormSource, ctDoc, ctSrc, Me.Tag, "LostFocus" '失去焦点
'End Sub

Private Sub Form_Load()

End Sub
=======
===MODULE1===
'模块 Module1 代码
Public moPage As Long

Public Function EventsHTML(nFormSource, Doc As MSHTML.HTMLDocument, ByVal Src As String, _
   ByVal DocTag As String, Optional ByVal EventName As String) As Boolean
   '获取网页事件的参数,并传递给原窗口
   Dim Events As IHTMLEventObj, Elem As IHTMLElement, Cancel As Boolean
   
   Set Events = Doc.parentWindow.event            '触发的事件
   Set Elem = Doc.parentWindow.event.srcElement   '触发事件的的网页元素
   If EventName = "" Then EventName = Events.Type '事件名称,如:MouseDown、MouseMove 等
   
  '调用原窗口(即 nFormSource,添加捕捉事件的窗口,实际就是 Form1 的不同实例)的过程,传递事件信息
   nFormSource.PageEvents EventName, Events, Elem, Doc, Src, DocTag, Cancel
   EventsHTML = Not Cancel '是否拦截此事件
End Function

Public Sub AddToCombo(nForm As Form)
  '将内嵌网页和框架名称添加到主窗口的 Combo2
   Dim I As Long, DocTag As String, Doc As MSHTML.HTMLDocument
   Dim URL As String, Src As String, IsIFrame As Boolean, IsMain As Boolean
   
   DocTag = nForm.Tag & "-Doc"
   
   On Error Resume Next
   
   '卸载失效的捕捉窗口
   For I = Forms.Count - 1 To 0 Step -1
      nTag = Forms(I).Tag
      If InStr(nTag, DocTag) = 1 Then
         Set Doc = Nothing
         DisURL = ""
         '调用捕捉窗口(Form2)的 GetDoc 过程获取有关参数
         Forms(I).GetDoc Doc, URL, Src, IsIFrame, IsMain
         DisURL = Doc.URL
         If DisURL = "" Then Unload Forms(I)
       End If
   Next
   
   '将内嵌网页和框架名称添加到主窗口的 Combo2
   For I = 0 To Forms.Count - 1
      nTag = Forms(I).Tag
      If InStr(nTag, DocTag) = 1 Then
         '调用捕捉窗口(Form2)的 GetDoc 过程获取有关参数
         Forms(I).GetDoc Doc, URL, Src, IsIFrame, IsMain
         If Not IsMain Then
            If IsIFrame Then
                + 1 & ".框架:" & nSrc & " ■ " & URL
            Else
                + 1 & ".网页:" & Doc.Title & " ■ " & URL
            End If
         End If
       End If
   Next
    = " 共 " & & " 个内嵌网页"
End Sub

Public Sub LoadDocForm(nForm As Form, Optional nDoc As MSHTML.HTMLDocument, Optional nIsMain As Boolean, _
   Optional nSrc As String, Optional nIsIFrame As Boolean, Optional UnloadAll As Boolean)
   '添加 或 卸载 用于捕捉网页事件的窗体
   'nSrc="" 表示是网页,否则表示是内嵌框架
   Dim I As Long, S As Long, nTag As String, DocTag As String, IsIFrame As Boolean
   Dim nURL As String, Doc As MSHTML.HTMLDocument, URL As String, Src As String, IsMain As Boolean
   
   DocTag = nForm.Tag & "-Doc"
   S = Forms.Count
   
   If UnloadAll Then '------ 卸载由 nForm 添加的所有事件捕捉窗体
      For I = S - 1 To 0 Step -1
         nTag = Forms(I).Tag
         If InStr(nTag, DocTag) = 1 Then Unload Forms(I)
      Next
      nForm.ctDocS = 0
      
       = " 无内嵌网页"
  Else '--------------------------添加 捕捉网页事件的隐式窗体
     nURL = nDoc.URL
     If LCase(nURL) = "about:blank" Then Exit Sub
     
     '检查捕捉窗口是否已存在
     For I = S - 1 To 0 Step -1
       nTag = Forms(I).Tag
       If InStr(nTag, DocTag) = 1 Then
          Set Doc = Nothing: URL = "": Src = "": IsIFrame = False
          On Error Resume Next
          '调用已有的捕捉窗口(Form2)的 GetDoc 过程获取有关参数
          Forms(I).GetDoc Doc, URL, Src, IsIFrame, IsMain
          On Error GoTo 0
         
          If nIsIFrame = IsIFrame Then
            If nIsIFrame Then
             '  If LCase(Src & URL) = LCase(nSrc & nURL) Then Exit Sub '该框架的事件捕捉窗口已存在
            Else
               If LCase(URL) = LCase(nURL) Then Exit Sub '该网页的事件捕捉窗口已存在
            End If
          End If
       End If
     Next
     
     '添加一个捕捉网页事件的窗体 Form2,并调用其 SetDoc 过程设置有关参数
     Dim DocForm As New Form2
     nForm.ctDocS = nForm.ctDocS + 1
     S = nForm.ctDocS
     DocTag = DocTag & S
     DocForm.SetDoc nForm, DocTag, nDoc, nSrc, nIsIFrame, nIsMain
  End If
End Sub
==========


搜索更多相关主题的帖子: WebBrowser PHP网站 浏览器 技术 键盘 
2014-02-10 13:34
快速回复:技术分享:简单VB的浏览器,但访问PHP网站内页时出错;单独用IE却可正 ...
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.032169 second(s), 7 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved