实例介绍
【实例简介】
【实例截图】
【核心代码】
VERSION 5.00
Object = "{33658027-1004-4E1E-8D35-C9146DF87919}#1.0#0"; "vbMHWB.dll"
Begin VB.Form frmMyIE
Caption = "MyIE网页浏览器"
ClientHeight = 9165
ClientLeft = 1920
ClientTop = 2340
ClientWidth = 14880
LinkTopic = "Form1"
ScaleHeight = 9165
ScaleWidth = 14880
Begin VB.CommandButton Command1
Caption = "Go"
Height = 375
Left = 13545
TabIndex = 1
Top = 5580
Width = 855
End
Begin VB.CommandButton Command4
Caption = "查看源文件"
Height = 375
Left = 9225
TabIndex = 25
Top = 585
Width = 1275
End
Begin VB.CheckBox Check5
Caption = "允许控件"
Height = 375
Left = 5760
TabIndex = 24
Top = 585
Value = 1 'Checked
Width = 1230
End
Begin VB.CheckBox Check4
Caption = "允许脚本"
Height = 375
Left = 4275
TabIndex = 23
Top = 585
Value = 1 'Checked
Width = 1185
End
Begin VB.CheckBox Check3
Caption = "显示框架"
Height = 375
Left = 2925
TabIndex = 22
Top = 585
Value = 1 'Checked
Width = 1050
End
Begin VB.CheckBox Check2
Caption = "显示视频"
Height = 375
Left = 1575
TabIndex = 20
Top = 585
Width = 1095
End
Begin VB.CheckBox Check1
Caption = "显示图片"
Height = 375
Left = 135
TabIndex = 19
Top = 585
Width = 1185
End
Begin VB.CommandButton Command3
Caption = "Command3"
Height = 870
Left = 13590
TabIndex = 16
Top = 4320
Width = 1770
End
Begin VB.CheckBox chkSource
Caption = "View source before scripts exec"
Height = 375
Left = 13095
Style = 1 'Graphical
TabIndex = 15
Top = 6030
Width = 2655
End
Begin VB.CommandButton cmdLoadHtml
Caption = "Load HTML"
Height = 375
Left = 13545
TabIndex = 14
Top = 7110
Width = 1095
End
Begin VB.CommandButton cmdPost
Caption = "Post Data"
Height = 375
Left = 13545
TabIndex = 13
Top = 6570
Width = 975
End
Begin VB.CommandButton cmdsaveAsBmp
Caption = "Save As Bitmap"
Height = 375
Left = 13680
TabIndex = 12
Top = 3690
Width = 1575
End
Begin VB.PictureBox picThumb
Appearance = 0 'Flat
AutoRedraw = -1 'True
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 6375
Left = 12825
ScaleHeight = 425
ScaleMode = 3 'Pixel
ScaleWidth = 129
TabIndex = 11
Top = 8055
Width = 1935
End
Begin VB.CommandButton cmdThumb
Caption = "Thumbnail 120x120"
Height = 375
Left = 13545
TabIndex = 10
Top = 2175
Width = 1935
End
Begin VB.CommandButton cmdZoom
Caption = "Zoom"
Height = 375
Left = 13770
TabIndex = 9
Top = 3195
Width = 735
End
Begin VB.ComboBox comboZoom
Height = 300
ItemData = "frmMyIE.frx":0000
Left = 13500
List = "frmMyIE.frx":0013
Style = 2 'Dropdown List
TabIndex = 8
Top = 2835
Width = 1455
End
Begin VB.ComboBox Combo1
Appearance = 0 'Flat
Height = 300
ItemData = "frmMyIE.frx":0040
Left = 840
List = "frmMyIE.frx":0042
TabIndex = 0
Text = "http://"
Top = 165
Width = 9450
End
Begin VB.CommandButton cmdSandBox
Caption = "Open in SandBox"
Height = 375
Left = 13545
TabIndex = 5
Top = 1710
Width = 1935
End
Begin VB.TextBox txtLog
Appearance = 0 'Flat
BorderStyle = 0 'None
Height = 1935
Left = 120
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 4
Top = 6480
Width = 13110
End
Begin VB.CheckBox chkHeaders
Caption = "显示详细请求消息"
Height = 375
Left = 7065
TabIndex = 3
Top = 585
Width = 1950
End
Begin VBMHWBLibCtl.vbWB vbWB1
Height = 4860
Left = 90
OleObjectBlob = "frmMyIE.frx":0044
TabIndex = 2
Top = 1485
Width = 12255
End
Begin VB.Image Command2
Height = 285
Index = 2
Left = 10890
Picture = "frmMyIE.frx":0068
Top = 165
Width = 285
End
Begin VB.Image Command2
Height = 285
Index = 0
Left = 10485
Picture = "frmMyIE.frx":04FB
Top = 165
Width = 285
End
Begin VB.Image Command2
Appearance = 0 'Flat
Height = 285
Index = 3
Left = 11250
Picture = "frmMyIE.frx":098C
Top = 165
Width = 240
End
Begin VB.Image Command2
Appearance = 0 'Flat
Height = 285
Index = 1
Left = 11610
Picture = "frmMyIE.frx":0DD3
Top = 165
Width = 240
End
Begin VB.Label Label2
Caption = "网址："
Height = 240
Left = 135
TabIndex = 21
Top = 180
Width = 600
End
Begin VB.Label LabelP
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
Caption = "空白"
ForeColor = &H80000008&
Height = 390
Index = 0
Left = 90
TabIndex = 17
Top = 1080
Width = 1695
End
Begin VB.Label lblWBCount
Caption = "1"
Height = 255
Left = 14040
TabIndex = 7
Top = 7605
Visible = 0 'False
Width = 375
End
Begin VB.Label Label1
Caption = "Label1"
Height = 375
Left = 90
TabIndex = 6
Top = 8550
Width = 13170
End
Begin VB.Label Label3
Height = 420
Left = 45
TabIndex = 18
Top = 1080
Width = 14820
End
Begin VB.Menu mnuWBTabs
Caption = "WBTabs"
Visible = 0 'False
Begin VB.Menu mnuWB
Caption = "about:blank"
Index = 0
End
End
Begin VB.Menu rightmenuweb
Caption = "rightmenuweb"
Visible = 0 'False
Begin VB.Menu rightmenuweb2
Caption = "关闭"
End
End
End
Attribute VB_Name = "frmMyIE"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'vbMHWB ActiveX control simple demonstration application
'Author: MH
'Email: mehr13@hotmail.com
'Last Update: Mar 15 2006
'
'Common terms used throughout:
'WB: Webbrowser
'WBCtl: Webbrowser Control
'UID: Unique ID
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'vbMHWB, uses the same Webbrowser control which VB, C , Delphi
'are using. In addition to new functionalities,
'vbMHWB control contains most of the properties, methods,
'and events that any other WB implementation come with.
'
'I have attempted to place the focus of this demo application
'on some of the new functionalities added by this control. The usual
'back, forward, ... have been omitted. To keep this demo's dependency free,
'I am using a hidden menu "mnuWBTabs" to simulate a multi tab.
'
'I do have an advanced demo application with multi tabs, ...
'If anyone is interested, please email me for the source binaries
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'To keep track of current WB being displayed
Public iCur As Integer
'Two bool arrays to hold back forward values for each wb
Private garrBackBtn() As Boolean
Private garrForwardBtn() As Boolean
Dim TopDocumentComplete, isNewWin, isNewWinCreate
Dim curLabel As Integer
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Const MOUSEEVENTF_LEFTDOWN = &H2
Const MOUSEEVENTF_LEFTUP = &H4
Const MOUSEEVENTF_MIDDLEDOWN = &H20
Const MOUSEEVENTF_MIDDLEUP = &H40
Const MOUSEEVENTF_MOVE = &H1
Const MOUSEEVENTF_ABSOLUTE = &H8000
Const MOUSEEVENTF_RIGHTDOWN = &H8
Const MOUSEEVENTF_RIGHTUP = &H10
Private Sub chkSource_Click()
On Error GoTo chkSource_Click_Error
If chkSource.value = vbChecked Then
vbWB1.SourceOnDocComplete(iCur) = True
Else
vbWB1.SourceOnDocComplete(iCur) = False
End If
Exit Sub
chkSource_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure chkSource_Click of Form frmMyIE"
End Sub
Private Function GotTopic(ByVal str22, ByVal strlen22)
If str22 = "" Then
GotTopic = ""
Exit Function
End If
Dim l, t, c, i, LableStr, regEx, Match, Matches
str22 = Replace(Replace(Replace(Replace(str22, " ", " "), """, Chr(34)), ">", ">"), "<", "<")
l = Len(str22)
t = 0
For i = 1 To l
c = Abs(Asc(Mid(str22, i, 1)))
If c > 255 Then
t = t 2
Else
t = t 1
End If
If t >= strlen22 Then
GotTopic = Left(str22, i)
If strLength(GotTopic) > strlen22 Then
GotTopic = Left(str22, i - 1)
End If
Exit For
Else
GotTopic = str22
End If
Next
' GotTopic = Replace(Replace(Replace(Replace(GotTopic, " ", " "), Chr(34), """), ">", ">"), "<", "<") & LableStr
End Function
Private Function strLength(STR) '求字符串长度。汉字算两个字符，英文算一个字符
On Error Resume Next
Dim WINNT_CHINESE
WINNT_CHINESE = (Len("中国") = 2)
If WINNT_CHINESE Then
Dim l, t, c
Dim i
l = Len(STR)
t = l
For i = 1 To l
c = Asc(Mid(STR, i, 1))
If c < 0 Then c = c 65536
If c > 255 Then
t = t 1
End If
Next
strLength = t
Else
strLength = Len(STR)
End If
If Err.Number <> 0 Then Err.Clear
End Function
Private Sub cmdLoadHtml_Click()
On Error GoTo cmdLoadHtml_Click_Error
Dim sHTml As String
If iCur < 1 Then Exit Sub
sHTml = "<html><body><h1>Stream Test</h1><p>This HTML content is being loaded from a stream.</p></body></html>"
sHTml = InputBox("Please enter HTML content", "Replace HTML Content", sHTml)
If LenB(sHTml) > 0 Then vbWB1.LoadHTMLFromString iCur, sHTml
Exit Sub
cmdLoadHtml_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdLoadHtml_Click of Form frmMyIE"
End Sub
Private Sub cmdPost_Click()
On Error GoTo cmdPost_Click_Error
'Choose POST or GET
'If ? present then use GET
'else POST raw data
Dim iiD As Integer
'Use POST
'abstractvb supports post - no ? char in data segment
vbWB1.WBPostData "http://abstractvb.com/search.asp", "SEARCHSTRING=VB.NET&SEARCHTYPE=CODE", iiD
'Use GET
'google search supports GET
'http://www.google.ca/search
'?
'hl=en&q=sea&btnG=Google Search&meta=
'vbWB1.WBPostData "http://www.google.ca/search?hl=en&q=sea&btnG=Google Search&meta=", "", iiD
Exit Sub
cmdPost_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdPost_Click of Form frmMyIE"
End Sub
Private Sub cmdsaveAsBmp_Click()
On Error GoTo cmdsaveAsBmp_Click_Error
Dim sFile As String
sFile = InputBox("Enter a filename", "File Name", "google1")
sFile = App.Path & "\" & sFile & ".bmp"
Screen.MousePointer = vbHourglass
vbWB1.SaveAsBitmap iCur, sFile
Screen.MousePointer = vbDefault
MsgBox "Saved BMP to " & sFile
Exit Sub
cmdsaveAsBmp_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdsaveAsBmp_Click of Form frmMyIE"
End Sub
''TEST
' REFRESH_NORMAL = 0,
' REFRESH_IFEXPIRED = 1,
' REFRESH_CONTINUE = 2,
' REFRESH_COMPLETELY = 3
' vbWB1.Refresh2 iCur, 3
' Exit Sub
Private Sub cmdThumb_Click()
On Error GoTo cmdThumb_Click_Error
Dim Index As Integer, iiD As Integer, iCount As Integer
Dim lX As Long, lY As Long, lW As Long, lH As Long
lX = 2
lY = 2
lW = 120 'picThumb.ScaleWidth
lH = 120 'picThumb.ScaleHeight
iCount = mnuWB.Count
If iCount = 0 Then Exit Sub
'Only the first three for now
If iCount > 3 Then iCount = 3
Screen.MousePointer = vbHourglass
For Index = 0 To iCount - 1
If Len(mnuWB(Index).Tag) > 0 Then
iiD = CInt(mnuWB(Index).Tag)
If iiD > 0 Then
vbWB1.DrawWBThumbnailOnWnd iiD, picThumb.hDC, lX, lY, lW, lH
lY = lY 126
End If
End If
Next
picThumb.Refresh
' picThumb.Picture = picThumb.Image
' SavePicture picThumb.Picture, App.Path & "/screen.bmp"
Screen.MousePointer = vbDefault
Exit Sub
cmdThumb_Click_Error:
Screen.MousePointer = vbDefault
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdThumb_Click of Form frmMyIE"
End Sub
Private Sub cmdZoom_Click()
On Error GoTo cmdZoom_Click_Error
If comboZoom.ListIndex < 0 Then Exit Sub
If vbWB1.WBPageTextSize(iCur) = comboZoom.ListIndex Then
MsgBox "Already zoomed with the requsted value"
Exit Sub
End If
'Get the zoom value does not work in form load
'Debug.Print "=" & CStr(vbWB1.WBPageTextSize(iCur))
vbWB1.WBPageTextSize(iCur) = comboZoom.ListIndex
Exit Sub
cmdZoom_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdZoom_Click of Form frmMyIE"
End Sub
Private Sub Combo1_KeyPress(KeyAscii As Integer)
On Error Resume Next
If KeyAscii = vbKeyReturn Then
Command1_Click
End If
End Sub
'Simple nav
Private Sub Command2_Click(Index As Integer)
On Error GoTo Command2_Click_Error
If iCur < 1 Then Exit Sub
Select Case Index
Case 0 'back
vbWB1.GoBack iCur
Case 1 'stop
vbWB1.Stop iCur
Case 2 'forward
vbWB1.GoForward iCur
Case 3 'forward
vbWB1.Refresh iCur
End Select
Exit Sub
Command2_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Command2_Click of Form frmMyIE"
End Sub
Private Sub Command2_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
For i = 0 To 3
Command2(i).BorderStyle = 0
If i = Index Then
Command2(Index).BorderStyle = 1
End If
Next
End Sub
Private Sub Command3_Click()
dateStart = Now()
Combo1.Text = "file:///C:/mytest.htm"
Command1_Click
While TopDocumentComplete = False
DoEvents
Sleep (100)
Wend
'MsgBox DateDiff("s", dateStart, Now())
Set vDoc = vbWB1.Document(iCur)
'Debug.Print Len(vDoc.documentElement.innerhtml)
For i = 0 To vDoc.All.Length - 1 '搜索全部文档
With vDoc.All(i)
If .tagname = "A" Then
Debug.Print vDoc.All(i - 1).tagname
Debug.Print .onclick
Debug.Print .Style.Color
Debug.Print .Style.cssText
If .classname = "font14" Then
.Click
While TopDocumentComplete = False
DoEvents
Sleep (100)
Wend
allhtml = vbWB1.Document(iCur).documentElement.innerhtml
telstr = dddddddddd
End If
End If
End With
Next i
'vDoc.getElementsByName("bb")(0).Click
'DLCTL_BGSOUNDS 浏览器组件播放同文档相联的背景声音；'
' DLCTL_DLIMAGES 浏览器组件从服务器下载图形；
'' DLCTL_DOWNLOADONLY 浏览器组件下载页面但不显示；
'' DLCTL_FORCEOFFLINE 浏览器组件工作在脱机方式。通过 URLMON 提出请求时， 即使计算机连接了互联网，也设置 BINDF_OFFLINEOPERATION 标志；
'' DLCTL_NO_BEHAVIORS 浏览器组件不执行任何行为；
'' DLCTL_NO_CLIENTPULL 浏览器组件不执行任何客户端的 pull 操作；
'' DLCTL_NO_DLACTIVEXCTLS 浏览器组件不下载文档中的任何 ActiveX 控件；
'' DLCTL_NO_FRAMEDOWNLOAD 浏览器组件对包含框架的页面进行语法分析但不下载任何帧， 同时忽略框架，不翻译任何 frame 标记；
'' DLCTL_NO_JAVA 浏览器组件不执行任何 Java applet；
'' DLCTL_NO_METACHARSET 浏览器组件隐藏文档中的 META 元素指示的字符集；
'' DLCTL_NO_RUNACTIVEXCTLS 浏览器组件不执行文档中的任何 ActiveX 控件；
'' DLCTL_NO_SCRIPTS 浏览器组件不执行任何脚本；
' DLCTL_OFFLINE 与 DLCTL_OFFLINEIFNOTCONNECTED 相同；
'' DLCTL_OFFLINEIFNOTCONNECTED 如果未连接互联网，浏览器组件将以脱机方式工作。通过 URLMON 提出请求时，即使计算机连接了互联网，也设置 BINDF_GETFROMCACHE_IF_NET_FAIL 标志；
'' DLCTL_PRAGMA_NO_CACHE 浏览器组件迫使请求发送给服务器并忽略代理，即使代理指明 数据是最新的也是如此。通过 URLMON 提出请求时，设置 BINDF_PRAGMA_NO_CACHE 标志；
'' DLCTL_RESYNCHRONIZE 浏览器组件忽略缓存中的数据并向服务器请求更新。如果服务器指明 缓存中的数据是更新了的则使用缓存数据。通过 URLMON 提出 请求时，设置 BINDF_RESYNCHRONIZE 标志；
'' DLCTL_SILENT 浏览器组件不显示用户界面。通过 URLMON 提出请求时，设置 BINDF_SILENTOPERATION 标志；
'' DLCTL_URL_ENCODING_DISABLE_UTF8 浏览器组件禁止 UTF-8 编码；
'' DLCTL_URL_ENCODING_ENABLE_UTF8 浏览器组件允许 UTF-8 编码；
'' DLCTL_VIDEOS 浏览器组件播放文档中包含的视频片断?
End Sub
Private Sub SleepMe(timeshi)
Set wsh = CreateObject("WScript.Shell")
wsh.Run """c:\sleep.exe"" " & timeshi, 0, True
Set wsh = Nothing
MsgBox "sssss"
End Sub
Private Sub Form_Activate()
LabelP(0).BackColor = &HF0F0F0
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Unlike VB's WBCtl, vbMHWB does not create a WB by default at runtime
'This enables one to use this control for file downloads using
'DownloadUrlAsync method (which fires OnFileDLxxx events to control DL)
'When adding WBs, each new WB is assigned a UID which
'is passed as wbUID param in events to distinguish which instance of WB has
'fired the event.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Form_Load()
isNewWinCreate = 0
On Error GoTo Form_Load_Error
Dim glWBDownloadFlags As Long
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'You can set/get either
'global flags which effects all instances of WBCtl being created
'by passing no value to the optional parameter of WBCtl properties
'or
'a WBCtl's specific flags which only effects that specific control
'identified by it's UID, passed to the property.
'Needs a refresh for the flags to take effect.
'Possibilities;
'One instance to view regular pages,
'one to view popups (limited options),
'one to view suspicoius pages (No Java, Javascript, ActiveX, Images, ...),
'One to act as a tooltip, ...
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Set global flags for UI, DLCTL, Context menu, Accelerator keys, Script error action
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'default UI flags: DOCHOSTUIFLAG_NO3DBORDER or DOCHOSTUIFLAG_FLAT_SCROLLBAR
vbWB1.DocumentHostUiFlags = WBDOCHOSTUIFLAG_NO3DBORDER Or _
WBDOCHOSTUIFLAG_FLAT_SCROLLBAR Or _
WBDOCHOSTUIFLAG_THEME
'Default DLCTL flags
glWBDownloadFlags = WBDOCDOWNLOADCTLFLAG_SILENT
If Check1.value = 1 Then
glWBDownloadFlags = glWBDownloadFlags Or WBDOCDOWNLOADCTLFLAG_DLIMAGES
End If
If Check2.value = 1 Then
glWBDownloadFlags = glWBDownloadFlags Or WBDOCDOWNLOADCTLFLAG_VIDEOS Or WBDOCDOWNLOADCTLFLAG_BGSOUNDS
End If
If Check3.value = 0 Then
glWBDownloadFlags = glWBDownloadFlags Or WBDOCDOWNLOADCTLFLAG_NO_FRAMEDOWNLOAD Or WBDOCDOWNLOADCTLFLAG_NOFRAMES
End If
If Check4.value = 0 Then
glWBDownloadFlags = glWBDownloadFlags Or WBDOCDOWNLOADCTLFLAG_NO_SCRIPTS Or WBDOCDOWNLOADCTLFLAG_NO_JAVA
End If
If Check5.value = 0 Then
glWBDownloadFlags = glWBDownloadFlags Or WBDOCDOWNLOADCTLFLAG_NO_DLACTIVEXCTLS Or WBDOCDOWNLOADCTLFLAG_NO_RUNACTIVEXCTLS
End If
vbWB1.DocumentDownloadControlFlags = glWBDownloadFlags
' vbWB1.DocumentDownloadControlFlags = WBDOCDOWNLOADCTLFLAG_NO_DLACTIVEXCTLS Or WBDOCDOWNLOADCTLFLAG_NO_FRAMEDOWNLOAD Or WBDOCDOWNLOADCTLFLAG_NOFRAMES Or WBDOCDOWNLOADCTLFLAG_SILENT
'Context menu action
'Default, display none
vbWB1.ContextMenuAction = WBCONTEXTMENUACTION_RAISE_ONCONTEXTMENU_EVENT
'Accelerator keys
'Default, block all
vbWB1.AcceletorKeysAction = WBACCELETORKEYSACTION_RAISE_ONACCELETORKEYS_EVENT
'Script error action
'Default,
vbWB1.ScriptErrorAction = WBSCRIPTERRORACTION_DISPLAY_NONE_STOP_RUNNING_SCRIPTS
'Default, we take over downloads internally
'please refer to OnFileDLxxx events
'vbWB1.UseIEDefaultFileDownload = False
'Initialize Boolean arrays to synchronize Back Forward btns
ReDim garrBackBtn(0)
ReDim garrForwardBtn(0)
'StartupURL, default = ""
vbWB1.StartupURL = "about:blank"
'Create a new WB, and get a UID for that instance of WB
'In a multi tab WB, one would store the UIDs within the
'tab lparam, or ... and later can access that specific instance of
'WB using the UID stored. Also almost all the methods, properties, and events
'contain a UID param, which enables one to access, modify, ... WBCtls
vbWB1.AddBrowser iCur
'Use the UID to register this one as Browser
vbWB1.RegisterAsBrowser(iCur) = True
'To enable dragdrop, set RegisterAsDropTarget prop to true
'To use IE default dragdrop functionality, set the second param
'of RegisterAsDropTarget property "bUseIEdefault" to true.
'By default control uses internal mechanism
vbWB1.RegisterAsDropTarget(iCur) = True
'Use DocumentCompleteWBEx to display the source of each page
'before any scripts are executed. Does not use DOM to get the source
'vbWB1.SourceOnDocComplete(iCur) = True
'Store the iud in the mnu tag
mnuWB(0).Tag = CStr(iCur)
LabelP(0).Tag = CStr(iCur)
Load frmFindText
Load frmSandBox
Exit Sub
Form_Load_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Form_Load of Form frmMyIE"
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
For i = 0 To 3
Command2(i).BorderStyle = 0
Next
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error GoTo Form_Unload_Error
Unload frmSandBox
Unload frmFindText
Exit Sub
Form_Unload_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Form_Unload of Form frmMyIE"
End Sub
Private Sub focusWEB(Index)
For i = 0 To LabelP.UBound
If i = Index Then
LabelP(Index).BackColor = &HF0F0F0
LabelP(i).BorderStyle = 1
Else
LabelP(i).BackColor = &HD8E4E8
LabelP(i).BorderStyle = 0
End If
Next
Combo1.Text = CStr(vbWB1.Document(CInt(LabelP(Index).Tag)).URL)
iCur = CInt(LabelP(Index).Tag)
vbWB1.PlaceWBOnTop CInt(LabelP(Index).Tag)
vbWB1.SetFocusW CInt(LabelP(Index).Tag)
End Sub
Private Sub Label3_DblClick()
isNewWin = True
isNewWinCreate = 1
Label3.ZOrder 1
Call GoWebUrl
vbWB1.NavigateSimple iCur, "about:blank"
End Sub
Private Sub LabelP_DblClick(Index As Integer)
vbWB1.NavigateSimple CInt(LabelP(Index).Tag), "about:blank"
zuihouYiGe = GetLabelPnum()
If zuihouYiGe > 1 Then
For i = Index 1 To LabelP.UBound
LabelP(i).Left = LabelP(i).Left - LabelP(i).Width
Next
LabelP(Index).Visible = False
End If
labelPc = GetLabelPnum()
labelwidth = 1695
If Me.ScaleWidth - LabelP(0).Left - 800 > labelPc * labelwidth Then
kk = 0
For i = 0 To LabelP.UBound
If LabelP(i).Visible = True Then
LabelP(i).Width = labelwidth
LabelP(i).Left = LabelP(0).Left kk * labelwidth
LabelP(i).ZOrder 0
kk = kk 1
End If
' Label3.ZOrder 1
Next
End If
If LabelP(Index).Tag = iCur Then
focusWEB 0
End If
End Sub
Private Sub LabelP_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbRightButton Then
'mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, X, Y, 0, 0
'
'DoEvents
'Sleep (10)
'focusWEB CInt(LabelP(Index).Tag)
curLabel = Index
PopupMenu rightmenuweb
Else
Dim iiD As Integer
Dim objDoc As Object
focusWEB Index
If Len(LabelP(Index).Tag) > 0 Then
iiD = CInt(LabelP(Index).Tag)
If iiD > 0 Then
iCur = iiD
Command2(0).Enabled = garrBackBtn(iCur - 1)
Command2(2).Enabled = garrForwardBtn(iCur - 1)
'Change caption, get the document object
Set objDoc = vbWB1.Document(iiD)
If Not objDoc Is Nothing Then
Caption = CStr(objDoc.Title)
If Caption = "" Then Caption = "MyIE浏览器"
Else
Caption = "Unable to retreive document Title"
End If
vbWB1.PlaceWBOnTop iiD
vbWB1.SetFocusW iiD
End If
End If
End If
End Sub
Private Sub mnuWB_Click(Index As Integer)
On Error GoTo mnuWB_Click_Error
Dim iiD As Integer
Dim objDoc As Object
If Len(mnuWB(Index).Tag) > 0 Then
iiD = CInt(mnuWB(Index).Tag)
If iiD > 0 Then
iCur = iiD
Command2(0).Enabled = garrBackBtn(iCur - 1)
Command2(2).Enabled = garrForwardBtn(iCur - 1)
'Change caption, get the document object
Set objDoc = vbWB1.Document(iiD)
If Not objDoc Is Nothing Then
Caption = CStr(objDoc.Title)
Else
Caption = "Unable to retreive document Title"
End If
vbWB1.PlaceWBOnTop iiD
vbWB1.SetFocusW iiD
End If
End If
Exit Sub
mnuWB_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure mnuWB_Click of Form frmMyIE"
End Sub
Private Sub rightmenuweb2_Click()
LabelP_DblClick curLabel
End Sub
Private Sub vbWB1_CommandStateChange(ByVal wbUID As Integer, ByVal Command As Long, ByVal Enable As Boolean)
On Error GoTo vbWB1_CommandStateChange_Error
If Command = 2 Then 'CSC_NAVIGATEBACK
garrBackBtn(wbUID - 1) = Enable
If wbUID = iCur Then
Command2(0).Enabled = Enable
End If
ElseIf Command = 1 Then 'CSC_NAVIGATEFORWARD
garrForwardBtn(wbUID - 1) = Enable
If wbUID = iCur Then
Command2(2).Enabled = Enable
End If
End If
Exit Sub
vbWB1_CommandStateChange_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_CommandStateChange of Form frmMyIE"
End Sub
Private Sub vbWB1_DocumentCompleteWBEx(ByVal wbUID As Integer, URL As Variant, ByVal pDisp As Object, ByVal isTopLevel As Boolean, ByVal sDocSource As String)
On Error GoTo vbWB1_DocumentCompleteWBEx_Error
Dim sURL As String
sURL = CStr(URL)
If isTopLevel = True Then
AddToLog ">>>vbWB1_DocumentCompleteWBEx- TopLevel - >>> " & sURL & vbCrLf & sDocSource
Else
AddToLog ">>>vbWB1_DocumentCompleteWBEx- >>> " & sURL & vbCrLf & sDocSource
End If
Exit Sub
vbWB1_DocumentCompleteWBEx_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_DocumentCompleteWBEx of Form frmMyIE"
End Sub
'==========================================
'Please visit http://msdn.microsoft.com/library/default.asp?url=/workshop/browser/hosting/reference/ifaces/dochostuihandler2/idochostuihandler2.asp
'for a complete reference and to understand the difference between GetOptionKeyPath and GetOverrideKeyPath methods.
'==========================================
Private Sub vbWB1_OnGetOptionKeyPath(ByVal wbUID As Integer, sRegistryOptionKeyPath As String)
On Error GoTo vbWB1_OnGetOptionKeyPath_Error
AddToLog ">>>vbWB1_OnGetOptionKeyPath"
Exit Sub
vbWB1_OnGetOptionKeyPath_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnGetOptionKeyPath of Form frmMyIE"
End Sub
Private Sub vbWB1_OnGetOverrideKeyPath(ByVal wbUID As Integer, sRegistryOverrideKeyPath As String)
On Error GoTo vbWB1_OnGetOverrideKeyPath_Error
AddToLog ">>>vbWB1_OnGetOverrideKeyPath"
Exit Sub
vbWB1_OnGetOverrideKeyPath_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnGetOverrideKeyPath of Form frmMyIE"
End Sub
Private Sub vbWB1_OnPostDataAvailable(ByVal PostUID As Integer, ByVal sURL As String, ByVal pData As String, CancelPost As Boolean)
On Error GoTo vbWB1_OnPostDataAvailable_Error
AddToLog ">>>vbWB1_OnPostDataAvailable" & vbCrLf & pData
Exit Sub
vbWB1_OnPostDataAvailable_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnPostDataAvailable of Form frmMyIE"
End Sub
Private Sub vbWB1_OnPostEnd(ByVal PostUID As Integer, ByVal sURL As String)
On Error GoTo vbWB1_OnPostEnd_Error
AddToLog ">>>vbWB1_OnPostEnd" & vbCrLf & PostUID
Exit Sub
vbWB1_OnPostEnd_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnPostEnd of Form frmMyIE"
End Sub
Private Sub vbWB1_OnPostError(ByVal PostUID As Integer, ByVal sURL As String, ByVal sErrorMsg As String)
On Error GoTo vbWB1_OnPostError_Error
AddToLog ">>>vbWB1_OnPostError" & vbCrLf & sErrorMsg
Exit Sub
vbWB1_OnPostError_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnPostError of Form frmMyIE"
End Sub
'CancelPost, default = False
Private Sub vbWB1_OnPostOnProgress(ByVal PostUID As Integer, ByVal sURL As String, ByVal lProgress As Long, ByVal lProgressMax As Long, ByVal lStatusCode As Long, ByVal sStatusText As String, CancelPost As Boolean)
On Error GoTo vbWB1_OnPostOnProgress_Error
AddToLog ">>>vbWB1_OnPostOnProgress" & vbCrLf & "lStatusCode= " & TranslatePostStatusCode(lStatusCode) & " =sStatusText=" & sStatusText
Exit Sub
vbWB1_OnPostOnProgress_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnPostOnProgress of Form frmMyIE"
End Sub
Private Sub vbWB1_OnPostResponse(ByVal PostUID As Integer, ByVal sURL As String, ByVal lResponseCode As Long, ByVal sResponseHeaders As String)
On Error GoTo vbWB1_OnPostResponse_Error
AddToLog ">>>vbWB1_OnPostResponse" & vbCrLf & _
"lResponseCode=" & lResponseCode & " =sResponseHeaders=" & sResponseHeaders
Exit Sub
vbWB1_OnPostResponse_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnPostResponse of Form frmMyIE"
End Sub
Private Sub vbWB1_OnWBDragEnter(ByVal wbUID As Integer, ByVal KeyState As Integer, ByVal ptX As Long, ByVal ptY As Long, lEffect As Long)
On Error GoTo vbWB1_OnWBDragEnter_Error
AddToLog ">>>vbWB1_OnWBDragEnter" & vbCrLf & "Keystate=" & CStr(KeyState) & " =X Y=" & CStr(ptX) & " " & CStr(ptY) & " =Effect=" & lEffect
'lEffect = DROPEFFECT.DROPEFFECT_COPY
Exit Sub
vbWB1_OnWBDragEnter_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnWBDragEnter of Form frmMyIE"
End Sub
Private Sub vbWB1_OnWBDragLeave(ByVal wbUID As Integer)
On Error GoTo vbWB1_OnWBDragLeave_Error
AddToLog ">>>vbWB1_OnWBDragLeave"
Exit Sub
vbWB1_OnWBDragLeave_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnWBDragLeave of Form frmMyIE"
End Sub
Private Sub vbWB1_OnWBDragOver(ByVal wbUID As Integer, ByVal KeyState As Integer, ByVal ptX As Long, ByVal ptY As Long, lEffect As Long)
On Error GoTo vbWB1_OnWBDragOver_Error
'AddToLog ">>>vbWB1_OnWBDragOver" & vbCrLf & "Keystate=" & CStr(KeyState) & " =X Y=" & CStr(ptX) & " " & CStr(ptY) & " =Effect=" & lEffect
'lEffect = DROPEFFECT.DROPEFFECT_COPY
Exit Sub
vbWB1_OnWBDragOver_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnWBDragOver of Form frmMyIE"
End Sub
Private Sub vbWB1_OnWBDrop(ByVal wbUID As Integer, ByVal KeyState As Integer, ByVal ptX As Long, ByVal ptY As Long, ByVal lpData As String, ByVal lWBDropFormat As Long, lEffect As Long)
On Error GoTo vbWB1_OnWBDrop_Error
If lWBDropFormat = WB_DROP_FORMATS.WB_CFHTML Then
AddToLog ">>>vbWB1_OnWBDrop::WB_CFHTML" & vbCrLf & lpData
ElseIf lWBDropFormat = WB_DROP_FORMATS.WB_CFTEXT Then
AddToLog ">>>vbWB1_OnWBDrop::WB_CFTEXT" & vbCrLf & lpData
ElseIf lWBDropFormat = WB_DROP_FORMATS.WB_CFSINGLEFILE Then
AddToLog ">>>vbWB1_OnWBDrop::WB_CFSINGLEFILE" & vbCrLf & lpData
vbWB1.NavigateSimple iCur, lpData
ElseIf lWBDropFormat = WB_DROP_FORMATS.WB_CFRTF Then
AddToLog ">>>vbWB1_OnWBDrop::WB_CFRTF" & vbCrLf & lpData
End If
'lEffect = DROPEFFECT.DROPEFFECT_COPY
Exit Sub
vbWB1_OnWBDrop_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnWBDrop of Form frmMyIE"
End Sub
'Multiple files
Private Sub vbWB1_OnWBDrop2(ByVal wbUID As Integer, ByVal KeyState As Integer, ByVal ptX As Long, ByVal ptY As Long, vData As Variant, lEffect As Long)
On Error GoTo vbWB1_OnWBDrop2_Error
Dim uB As Long, i As Long
AddToLog ">>>vbWB1_OnWBDrop2" & vbCrLf & "Keystate=" & CStr(KeyState) & " =X Y=" & CStr(ptX) & " " & CStr(ptY) & " =Effect=" & lEffect
If VarType(vData) = (vbString Or vbArray) Then
uB = UBound(vData)
'item 0 is the first file clicked among the selected file names
For i = 0 To uB
AddToLog "i=" & CStr(i) & " Data=" & vData(i)
Next
Else
AddToLog ">>>vbWB1_OnWBDrop2- Wrong Array Type."
End If
Exit Sub
vbWB1_OnWBDrop2_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnWBDrop2 of Form frmMyIE"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fired by HTTP or HTTPS protocol handler before sending request headers to a server
'Fired after BeforeNavigate2
'This includes html, images, css, ...
'To activate or deactivate protocol handlers use RegisterHTTPprotocol or RegisterHTTPSprotocol
'Additional headers can be added using sAdditionalHeaders param
'Default, Cancel = False. Request can be cancelled by setting Cancel to TRUE.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_ProtocolHandlerOnBeginTransaction(ByVal wbUID As Integer, ByVal sURL As String, ByVal sRequestHeaders As String, sAdditionalHeaders As String, Cancel As Boolean)
On Error GoTo vbWB1_ProtocolHandlerOnBeginTransaction_Error
AddToLog ">>>ProtocolHandlerOnBeginTransaction>>>wbUID>>> " & CStr(wbUID) & vbCrLf & _
"RequestHeaders>>>" & vbCrLf & sRequestHeaders
Exit Sub
vbWB1_ProtocolHandlerOnBeginTransaction_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_ProtocolHandlerOnBeginTransaction of Form frmMyIE"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fired by HTTP or HTTPS protocol handler after receiving response headers from server
'this includes and redirect headers that were send after a normal response
'Fired before DocumentComplete
'To activate or deactivate protocol handlers use RegisterHTTPprotocol or RegisterHTTPSprotocol
'sRedirectedUrl = if has value, indicates the during initial request, we were redirected to another site
'Default, Cancel = False. Request can be cancelled by setting Cancel to TRUE.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_ProtocolHandlerOnResponse(ByVal wbUID As Integer, ByVal sURL As String, ByVal sResponseHeaders As String, ByVal sRedirectedUrl As String, ByVal sRedirectHeaders As String, Cancel As Boolean)
On Error GoTo vbWB1_ProtocolHandlerOnResponse_Error
AddToLog ">>>ProtocolHandlerOnResponse>>>wbUID>>> " & CStr(wbUID) & vbCrLf & _
">>>RedirectedURL>>> " & sRedirectedUrl & vbCrLf & _
">>>RedirectHeaders>>>" & vbCrLf & sRedirectHeaders & _
">>>ResponseHeaders>>>" & vbCrLf & sResponseHeaders
Exit Sub
vbWB1_ProtocolHandlerOnResponse_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_ProtocolHandlerOnResponse of Form frmMyIE"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'By default, vbMHWB takes over all WB file downloads internally. This gives the developer
'ability to control the download using OnFileDLxxx events
'If you wish to use the default behaviour of WBCtl set UseIEDefaultFileDownload to true
'
'This event is called in place of FileDownload event if UseIEDefaultFileDownload = False
'
'FileDlUID, UID for this file download, can be used to stop a DL using CancelFileDl method
'Default, SendProgressEvents = True (sends OnFileDLProgress)
'sFilename= xxx.zip
'sExt= .zip
'sURL= http://www.site.com/folder/xxxxx/xxx.zip
'sRedirURL= Url of the site we have been redirected to
'sExtraHeaders= Response headers received from server in response to our request
'Default, bStopDownload = False
'sPathToSave= Must be in form of Fullpath/Filename.ext. if no value is passed
'then the file will be saved in the same directory as the exe with the format sFilename/sExt
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_FileDownloadEx(ByVal wbUID As Integer, ByVal FileDlUID As Integer, ByVal sURL As String, ByVal sFilename As String, ByVal sExt As String, ByVal sExtraHeaders As String, ByVal sRedirURL As String, SendProgressEvents As Boolean, bStopDownload As Boolean, sPathToSave As String)
On Error GoTo vbWB1_FileDownloadEx_Error
SendProgressEvents = False
AddToLog ">>>vbWB1_FileDownloadEx>>>FileName>>>" & sFilename & vbCrLf & _
">>>URL>>> " & sURL & vbCrLf & ">>>RedirectedURL>>> " & sRedirURL & vbCrLf & _
">>>sExtraHeaders>>>" & vbCrLf & sExtraHeaders
Exit Sub
vbWB1_FileDownloadEx_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_FileDownloadEx of Form frmMyIE"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'NewWindow3 event
'Only available in XP sp2 and higher
'Fires before NewWindow2
'Default, Cancel = true
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_NewWindow3(ByVal wbUID As Integer, ppDisp As Object, Cancel As Boolean, ByVal lFlags As Long, ByVal sURLContext As String, ByVal sURL As String)
On Error GoTo vbWB1_NewWindow3_Error
Cancel = False
AddToLog ">>>New Winodw3>>>"
Exit Sub
vbWB1_NewWindow3_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_NewWindow3 of Form frmMyIE"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fires when an accelerator key is pressed if we have set the
'ContextMenuAction to WBCONTEXTMENUACTION_RAISE_ONCONTEXTMENU_EVENT
'then you will receive events for each accelerator key activated
'default, Cancel = False (displays WB default context menu)
''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_OnAcceletorKeys(ByVal wbUID As Integer, ByVal nKeyCode As Integer, ByVal nVirtExtKey As Integer, Cancel As Boolean)
On Error GoTo vbWB1_OnAcceletorKeys_Error
'To cancel the action, set
'Cancel = True
If nVirtExtKey = vbKeyControl Then
Select Case nKeyCode
Case vbKeyA
AddToLog "OnAcceletorKeys_vbKeyA"
Case vbKeyC
AddToLog "OnAcceletorKeys_vbKeyC"
Case vbKeyE
AddToLog "OnAcceletorKeys_vbKeyE"
Case vbKeyF
Cancel = True
frmFindText.Show , Me
AddToLog "OnAcceletorKeys_vbKeyF"
Case vbKeyH
AddToLog "OnAcceletorKeys_vbKeyH"
Case vbKeyI
AddToLog "OnAcceletorKeys_vbKeyI"
Case vbKeyN
AddToLog "OnAcceletorKeys_vbKeyN"
'Open current URL in a new window
Case vbKeyO
AddToLog "OnAcceletorKeys_vbKeyO"
Case vbKeyP
AddToLog "OnAcceletorKeys_vbKeyP"
Case vbKeyV
AddToLog "OnAcceletorKeys_vbKeyV"
Case vbKeyX
AddToLog "OnAcceletorKeys_vbKeyX"
Case Else
AddToLog "OnAcceletorKeys_Unknown_nKeyCode"
End Select
ElseIf nVirtExtKey = vbKeyMenu Then
Select Case nKeyCode
Case vbKeyHome
AddToLog "OnAcceletorKeys_vbKeyHome"
Case vbKeyLeft
AddToLog "OnAcceletorKeys_vbKeyLeft"
Case vbKeyRight
AddToLog "OnAcceletorKeys_vbKeyRight"
Case Else
AddToLog "OnAcceletorKeys_Unknown_nVirtExtKey"
End Select
Else
AddToLog "OnAcceletorKeys_Unknown_nVirtExtKey"
End If
Exit Sub
vbWB1_OnAcceletorKeys_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnAcceletorKeys of Form frmMyIE"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Network authentication
'Supports basic authentication
'can be used to automate network loggins without user interaction
'Default, Cancel = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_OnAuthentication(ByVal wbUID As Integer, sUsername As String, sPassword As String, Cancel As Boolean)
On Error GoTo vbWB1_OnAuthentication_Error
'Ask user for info
Load frmLogin
frmLogin.Show vbModal, Me
If frmLogin.LoginSucceeded = True Then
sUsername = frmLogin.txtUserName
sPassword = frmLogin.txtPassword
Else
Cancel = True
End If
Unload frmLogin
Exit Sub
vbWB1_OnAuthentication_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnAuthentication of Form frmMyIE"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fired before context menu is displayed
'default, ctxDisplay = flase, display no contextmenu
'to receive this event, set ContextMenuAction to WBACCELETORKEYSACTION_RAISE_ONACCELETORKEYS_EVENT
'ContextMenuAction = 0, no ctxmnus - no event is generated
'ContextMenuAction = 1, IE default ctxmnus - no event is generated
'ContextMenuType = refer to WBCONTEXTMENUTYPE_xxxxx enum
'X and Y are based on screen coordinates
'ObjElem is the actual HTMLElement that generated this event
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_OnContextMenu(ByVal wbUID As Integer, ByVal ContextMenuType As Long, ByVal X As Long, ByVal Y As Long, ByVal ObjElem As Object, ctxDisplay As Boolean)
On Error GoTo vbWB1_OnContextMenu_Error
Dim sTmp As String
Dim objTmp As Object
If ContextMenuType = VBMHWBLibCtl.WBCONTEXTMENUTYPE_ANCHOR Then
AddToLog "OnContextMenu_ANCHOR>> " & CStr(ObjElem.href)
ElseIf ContextMenuType = VBMHWBLibCtl.WBCONTEXTMENUTYPE_IMAGE Then
AddToLog "OnContextMenu_IMAGE>> " & CStr(ObjElem.src)
'Check to see if the parent is a ALINK
Set objTmp = ObjElem.parentElement
If Not objTmp Is Nothing Then
sTmp = "" & objTmp.tagname
If LCase(sTmp) = "a" Then
AddToLog "OnContextMenu_IMAGE_ANCHOR>> " & CStr(objTmp.href)
End If
End If
ElseIf ContextMenuType = VBMHWBLibCtl.WBCONTEXTMENUTYPE_TEXTSELECT Then
AddToLog "OnContextMenu_TEXTSELECT"
ElseIf ContextMenuType = VBMHWBLibCtl.WBCONTEXTMENUTYPE_CONTROL Then
AddToLog "OnContextMenu_CONTROL"
ctxDisplay = True
ElseIf ContextMenuType = VBMHWBLibCtl.WBCONTEXTMENUTYPE_VSCROLL Or ContextMenuType = VBMHWBLibCtl.WBCONTEXTMENUTYPE_HSCROLL Then
AddToLog "OnContextMenu_VSCROLL_HSCROLL"
ctxDisplay = True
Else 'Unknown/Default - Display our own menu
AddToLog "OnContextMenu_Unknown_Default"
ctxDisplay = True
End If
Exit Sub
vbWB1_OnContextMenu_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnContextMenu of Form frmMyIE"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Same DocumentComplete, except with a new param isTopLevel
'indicating if the main document that initiated the navigation
'has READYSTATE_COMPLETE. No need to compare pDisp with the main
'doc object.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_DocumentComplete(ByVal wbUID As Integer, URL As Variant, ByVal pDisp As Object, ByVal isTopLevel As Boolean)
On Error GoTo vbWB1_DocumentComplete_Error
Dim objDoc As Object
Dim sURL As String
sURL = CStr(URL)
If sURL = "about:blank" Then Exit Sub
If isTopLevel = True Then
Set objDoc = pDisp.Document
If Not objDoc Is Nothing Then
TopDocumentComplete = True
AddToLog ">>>vbWB1_DocumentComplete-TopLevel-objDoc->>> " & CStr(objDoc.URL)
Combo1.AddItem CStr(objDoc.URL), 0
Combo1.ListIndex = 0
Else
AddToLog ">>>vbWB1_DocumentComplete-TopLevel->>> " & sURL
End If
'Set focus
Else
Set objDoc = pDisp.Document
If Not objDoc Is Nothing Then
AddToLog ">>>vbWB1_DocumentComplete-objDoc->>> " & CStr(objDoc.URL)
Else
AddToLog ">>>vbWB1_DocumentComplete->>> " & sURL
End If
End If
mnuWB(wbUID - 1).Caption = CStr(objDoc.URL)
Exit Sub
vbWB1_DocumentComplete_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_DocumentComplete of Form frmMyIE"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fired before sending request headers to server. Gives client a chance to add additional headers.
'Example:
'If local file exists then set bResuming = True and add Range header to request
'If server supports this header, it will resume download
' 'Syntax: Range: bytes=n-m
' 'Range = "Range" ":" ranges-specifier
' 'A client can use this header to request one or more segments of a document.
' sAdditionalRequestHeaders = "Range: bytes=" & CStr(LocalFileSize) & "-" & vbCrLf
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_OnFileDLBeginningTransaction(ByVal FileDlUID As Integer, ByVal sURL As String, ByVal sRequestHeaders As String, sAdditionalRequestHeaders As String, bResuming As Boolean, bCancel As Boolean)
On Error GoTo vbWB1_OnFileDLBeginningTransaction_Error
AddToLog ">>>vbWB1_OnFileDLBeginningTransaction>>>" & _
vbCrLf & ">>>URL>>> " & sURL & vbCrLf & ">>>RequestHeaders>>>" & vbCrLf & sRequestHeaders
Exit Sub
vbWB1_OnFileDLBeginningTransaction_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnFileDLBeginningTransaction of Form frmMyIE"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fired after receiving the first initial response from server.
'Can examine sResponseHeaders and lResponseCode to determine wheher to continue
'or abort the download
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_OnFileDLResponse(ByVal FileDlUID As Integer, ByVal sURL As String, ByVal lResponseCode As Long, ByVal sResponseHeaders As String, CancelDl As Boolean)
On Error GoTo vbWB1_OnFileDLResponse_Error
'Check return codes
If lResponseCode = 301 Or lResponseCode > 399 Then
'Notify user and see if they want to delete item from list
MsgBox "OnFileDLResponse - Server error. CODE: " & TranslateStatusCode(lResponseCode) & vbCrLf & "Aborting Download...", vbOKOnly vbCritical
CancelDl = True
Exit Sub
End If
'AddToLog ">>>vbWB1_OnFileDLResponse>>>" & vbCrLf & ">>>ResponseCode>>> " & lResponseCode & vbCrLf & ">>>sResponseHeaders>>> " & sResponseHeaders
Exit Sub
vbWB1_OnFileDLResponse_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnFileDLResponse of Form frmMyIE"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fired to indicate the progress of a file dl
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_OnFileDLProgress(ByVal FileDlUID As Integer, ByVal sURL As String, ByVal lProgress As Long, ByVal lProgressMax As Long, CancelDl As Boolean)
On Error GoTo vbWB1_OnFileDLProgress_Error
AddToLog ">>>vbWB1_OnFileDLProgress>>> " & CStr(lProgress) & " of " & CStr(lProgressMax)
Exit Sub
vbWB1_OnFileDLProgress_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnFileDLProgress of Form frmMyIE"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fired to indicate that errors have occured duing download
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_OnFileDLDownloadError(ByVal FileDlUID As Integer, ByVal sURL As String, ByVal sErrorMsg As String)
On Error GoTo vbWB1_OnFileDLDownloadError_Error
AddToLog ">>>vbWB1_OnFileDLDownloadError>>> " & sURL & vbCrLf & ">>>ErrMsg>>> " & sErrorMsg
Exit Sub
vbWB1_OnFileDLDownloadError_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnFileDLDownloadError of Form frmMyIE"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fired to indicate that file download has ended successfully
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_OnFileDLEndDownload(ByVal FileDlUID As Integer, ByVal sURL As String)
On Error GoTo vbWB1_OnFileDLEndDownload_Error
AddToLog ">>>vbWB1_OnFileDLEndDownload>>> " & sURL
Exit Sub
vbWB1_OnFileDLEndDownload_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnFileDLEndDownload of Form frmMyIE"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fired to signal that a download has been cancelled.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_OnFileDLCancelDownload(ByVal FileDlUID As Integer, ByVal sURL As String, ByVal CancelledDuringDL As Boolean)
On Error GoTo vbWB1_OnFileDLCancelDownload_Error
AddToLog ">>>vbWB1_OnFileDLCancelDownload>>> CancelledDuringDL >> " & CStr(CancelledDuringDL)
Exit Sub
vbWB1_OnFileDLCancelDownload_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnFileDLCancelDownload of Form frmMyIE"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'CAUTION:
'Using this event incorrectly may place the client PC open for abuse
'You can either use the IE registry values to read user security settings
'or do as IE does, prompt the user and store the result in a storage of some sort so as
'not to prompt the user all the time
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_OnHTTPSecurityProblem(ByVal wbUID As Integer, ByVal lProblem As Long, Cancel As Boolean)
On Error GoTo vbWB1_OnHTTPSecurityProblem_Error
'ERROR_INTERNET_HTTP_TO_HTTPS_ON_REDIR
'ERROR_INTERNET_HTTPS_TO_HTTP_ON_REDIR
If MsgBox("Security Problem:" & vbCrLf & TranslateStatusCode(lProblem) & vbCrLf & "Proceed?", vbYesNo vbCritical) = vbYes Then
Cancel = False
End If
Exit Sub
vbWB1_OnHTTPSecurityProblem_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnHTTPSecurityProblem of Form frmMyIE"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Fired before an HTML message is about to be displayed.
'Can change the message or stop displaying message.
'No need to set the Silent property of WB to True to stop these msgs.
'Default ShwMsg = False
'Sample:
'Your current security settings prohibit running ActiveX controls on this page. As a result, the page may not display correctly.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub vbWB1_ShowMessage(ByVal wbUID As Integer, sMsg As String, ShowMsg As Boolean)
On Error GoTo vbWB1_ShowMessage_Error
AddToLog ">>>vbWB1_ShowMessage>>>" & vbCrLf & sMsg
'ShowMsg = False
ShowMsg = True
Exit Sub
vbWB1_ShowMessage_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_ShowMessage of Form frmMyIE"
End Sub
Function GetLastLabelP()
zuihouYiGe = 0
For k = LabelP.UBound To 0 Step -1
If LabelP(k).Visible = True Then
zuihouYiGe = k
Exit For
End If
Next
GetLastLabelP = zuihouYiGe
End Function
Function GetLabelPnum()
zuihouYiGe = 0
For k = LabelP.UBound To 0 Step -1
If LabelP(k).Visible = True Then
zuihouYiGe = zuihouYiGe 1
End If
Next
GetLabelPnum = zuihouYiGe
End Function
Private Sub vbWB1_NewWindow2(ByVal wbUID As Integer, ppDisp As Object, Cancel As Boolean)
On Error GoTo vbWB1_NewWindow2_Error
Cancel = False
isNewWin = True
curLabel = wbUID - 1
Call GoWebUrl
vbWB1.RegisterAsBrowser(iCur) = True
Set ppDisp = vbWB1.ObjectWB(iCur)
vbWB1.PlaceWBOnTop wbUID
vbWB1.SetFocusW wbUID
AddToLog ">>>New Winodw2>>>"
Exit Sub
vbWB1_NewWindow2_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_NewWindow2 of Form frmMyIE"
End Sub
Private Sub vbWB1_BeforeNavigate2(ByVal wbUID As Integer, URL As Variant, ByVal pDisp As Object, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
On Error GoTo vbWB1_BeforeNavigate2_Error
Dim sURL As String
Dim bCracked As Boolean
sURL = CStr(URL)
' If sURL = "about:blank" Then Exit Sub
'Attempt to crack URL
vbWB1.ucInternetCrackUrl sURL, bCracked
'If failed then we stop navigation
'due to the fact that a corrupted URL will
'cause a NavigateError event to fire with lStat = 2
'which indicates that the HTML doc (the instance of WB)
'is corrupted and needs to destroyed. This can be handled
'from DocumentComplete event using a flag set in NavigateError
If bCracked = False Then
Cancel = True
vbWB1.Stop wbUID
vbWB1.NavigateSimple wbUID, "about:blank"
AddToLog ">>>vbWB1_BeforeNavigate2-CANCELLED-CORRUPTED-URL>>> " & sURL
Exit Sub
End If
AddToLog ">>>vbWB1_BeforeNavigate2>>> " & CStr(URL)
Exit Sub
vbWB1_BeforeNavigate2_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_BeforeNavigate2 of Form frmMyIE"
End Sub
'Default, Cancel = true
Private Sub vbWB1_NavigateError(ByVal wbUID As Integer, ByVal pDisp As Object, URL As Variant, TargetFrameName As Variant, StatusCode As Variant, Cancel As Boolean)
On Error GoTo vbWB1_NavigateError_Error
Dim lStat As Long
lStat = CLng(StatusCode)
'Here we get nav errors for file download with status code 200(OK)
If lStat = enumInetNav.HTTP_STATUS_CONTINUE Or _
lStat = enumInetNav.HTTP_STATUS_ACCEPTED Or _
lStat = enumInetNav.HTTP_STATUS_OK Or _
lStat = enumInetNav.HTTP_STATUS_REDIRECT Or _
lStat = enumInetNav.HTTP_STATUS_REQUEST_TIMEOUT Then Exit Sub 'Let wb show a timeout page
AddToLog ">>>vbWB1_NavigateError>>> " & CStr(URL) & vbCrLf & ">>>StatusCode>>> " & TranslateStatusCode(lStat)
Cancel = False
Exit Sub
vbWB1_NavigateError_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_NavigateError of Form frmMyIE"
End Sub
Private Sub vbWB1_StatusTextChange(ByVal wbUID As Integer, ByVal Text As String)
On Error GoTo vbWB1_StatusTextChange_Error
Label1.Caption = Text
Exit Sub
vbWB1_StatusTextChange_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_StatusTextChange of Form frmMyIE"
End Sub
Private Sub vbWB1_TitleChange(ByVal wbUID As Integer, ByVal Text As String)
On Error GoTo vbWB1_TitleChange_Error
Caption = Text
If Text = "" Then
Caption = "MyIE浏览器"
End If
LabelP(wbUID - 1).Caption = vbCrLf & GotTopic(Text, 14) & "..."
Exit Sub
vbWB1_TitleChange_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_TitleChange of Form frmMyIE"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub cmdSandBox_Click()
On Error GoTo cmdSandBox_Click_Error
'vbWB1.ViewSource iCur 'works
'vbWB1.Find iCur 'works
'vbWB1.OrganizeFavorites 'works
'vbWB1.SaveAs iCur 'works
'vbWB1.PrintPreview iCur 'works
'vbWB1.ViewIEOptions iCur 'works
'vbWB1.FileOpen iCur 'Does not work
'vbWB1.Save iCur 'Does not work
'Exit Sub
If frmSandBox.Visible = False Then frmSandBox.Show , Me
frmSandBox.vbWB1.Navigate frmSandBox.hCurWB, Combo1.Text
Exit Sub
cmdSandBox_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdSandBox_Click of Form frmMyIE"
End Sub
Function downint(ByVal value As Single) As Long
Select Case Sgn(value)
Case 1
downint = Int(value)
Case 0
downint = -1
Case -1
downint = Int(value)
End Select
End Function
Sub GoWebUrl()
glWBDownloadFlags = WBDOCDOWNLOADCTLFLAG_SILENT
If Check1.value = 1 Then
glWBDownloadFlags = glWBDownloadFlags Or WBDOCDOWNLOADCTLFLAG_DLIMAGES
End If
If Check2.value = 1 Then
glWBDownloadFlags = glWBDownloadFlags Or WBDOCDOWNLOADCTLFLAG_VIDEOS Or WBDOCDOWNLOADCTLFLAG_BGSOUNDS
End If
If Check3.value = 0 Then
glWBDownloadFlags = glWBDownloadFlags Or WBDOCDOWNLOADCTLFLAG_NO_FRAMEDOWNLOAD Or WBDOCDOWNLOADCTLFLAG_NOFRAMES
End If
If Check4.value = 0 Then
glWBDownloadFlags = glWBDownloadFlags Or WBDOCDOWNLOADCTLFLAG_NO_SCRIPTS Or WBDOCDOWNLOADCTLFLAG_NO_JAVA
End If
If Check5.value = 0 Then
glWBDownloadFlags = glWBDownloadFlags Or WBDOCDOWNLOADCTLFLAG_NO_DLACTIVEXCTLS Or WBDOCDOWNLOADCTLFLAG_NO_RUNACTIVEXCTLS
End If
vbWB1.DocumentDownloadControlFlags = glWBDownloadFlags
Dim iIndex As Integer, newTab As Long
Dim sURL As String
TopDocumentComplete = False
sURL = Combo1.Text
If LenB(sURL) = 0 Then Exit Sub
If Len(sURL) > 25 Then sURL = Left(sURL, 25) & "..."
If isNewWinCreate = 0 Then
For i = 0 To LabelP.UBound
If LabelP(i).Visible = True Then
If CStr(vbWB1.Document(CInt(LabelP(i).Tag)).URL) = "about:blank" Then
iCur = CInt(LabelP(i).Tag)
isNewWin = False
Exit For
End If
End If
Next
End If
' If isNewWinCreate = 2 Then
' isNewWin = False
'
' End If
'Using UID, obtained from calling AddBrowser
'to access this instance of WBCtl
' vbWB1.Stop iCur
'Create a new WB
If isNewWin = True Then
'Adjust Back Forward btns array size
ReDim Preserve garrBackBtn(vbWB1.Count)
ReDim Preserve garrForwardBtn(vbWB1.Count)
vbWB1.AddBrowser iIndex
If iIndex > 0 Then
iCur = iIndex
Load mnuWB(mnuWB.Count)
mnuWB(mnuWB.UBound).Tag = CStr(iIndex)
mnuWB(mnuWB.UBound).Caption = iCur
' lblWBCount.Caption = CStr(mnuWB.Count)
zuihouYiGe = GetLastLabelP()
Load LabelP(LabelP.Count)
LabelP(LabelP.UBound).Tag = CStr(iIndex)
LabelP(LabelP.UBound).Visible = True
If LabelP.UBound - 1 >= 0 Then LabelP(LabelP.UBound).Left = LabelP(zuihouYiGe).Left LabelP(zuihouYiGe).Width
' LabelP(LabelP.UBound).Caption = iCur
LabelP(LabelP.UBound).BackColor = &HD8E4E8
LabelP(LabelP.UBound).BorderStyle = 0
LabelP(LabelP.UBound).ZOrder 0
labelPc = GetLabelPnum()
If Me.Width - LabelP(0).Left - 800 < labelPc * LabelP(0).Width Then
labelwidth = downint((Me.Width - LabelP(0).Left - 800) / labelPc)
kk = 0
For i = 0 To LabelP.UBound
If LabelP(i).Visible = True Then
LabelP(i).Width = labelwidth
LabelP(i).Left = LabelP(0).Left kk * labelwidth
LabelP(i).ZOrder 0
kk = kk 1
End If
Next
End If
' focusWEB LabelP.UBound
End If
Else
'Update the current menu
mnuWB(iCur - 1).Caption = sURL
End If
Command2(0).Enabled = garrBackBtn(iCur - 1)
Command2(2).Enabled = garrForwardBtn(iCur - 1)
End Sub
Private Sub Command1_Click()
On Error GoTo Command1_Click_Error
isNewWin = False
'isNewWinCreate = 2
Call GoWebUrl
vbWB1.NavigateSimple iCur, Combo1.Text
Exit Sub
Command1_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Command1_Click of Form frmMyIE"
End Sub
Public Sub AddToLog(strLog As String)
On Error GoTo AddToLog_Error
txtLog.SelStart = Len(txtLog.Text)
txtLog.SelText = strLog & vbCrLf
txtLog.SelStart = Len(txtLog.Text)
Exit Sub
AddToLog_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AddToLog of Form frmMyIE"
End Sub
'Un/Register HTTP and/or HTTPS protocol
'to receive events for ProtocolHandlerOnBeginTransaction,
'and ProtocolHandlerOnResponse events
'This action effects all instances of this activex control
Private Sub chkHeaders_Click()
On Error GoTo chkHeaders_Click_Error
If chkHeaders.value = vbChecked Then
chkHeaders.Caption = "Click to stop display of HTTP HTTPS Headers"
vbWB1.RegisterHTTPprotocol True
vbWB1.RegisterHTTPSprotocol True
Else
chkHeaders.Caption = "Click to display HTTP HTTPS Headers"
vbWB1.RegisterHTTPprotocol False
vbWB1.RegisterHTTPSprotocol False
End If
Exit Sub
chkHeaders_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure chkHeaders_Click of Form frmMyIE"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This event is fired numerous times for every action WB needs to take for a URL
'in regards to URLACTION security, refer to enumURLACTION for a list of possible
'actions. Also check with MSDN, they add new ones all the time:)
'The current list of URLACTIONs that will not be passed to the custom security manager
'in most circumstances by Internet Explorer 5 are:
' URLACTION_SHELL_FILE_DOWNLOAD
' URLACTION_COOKIES
' URLACTION_JAVA_PERMISSIONS
' URLACTION_SCRIPT_PASTE
'There is no workaround for this problem. The behavior for the URLACTION can only be
'changed for all browser clients on the system by altering the security zone settings
'from Internet Options.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Default value of bHandled = false
'PUAF, one of PUAF enum (MSDN)
Private Sub vbWB1_WBProcessUrlAction(ByVal wbUID As Integer, ByVal sURL As String, ByVal lUrlAction As Long, ByVal PUAF_Flag As Long, lpUrlPolicy As Long, bHandled As Boolean)
On Error GoTo vbWB1_WBProcessUrlAction_Error
'To have your own policy take effect based on a lUrlAction
'Set lpUrlPolicy to desiered URLPOLICY_ flag
'Set bHandled to true
Exit Sub
vbWB1_WBProcessUrlAction_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_WBProcessUrlAction of Form frmMyIE"
End Sub
'Default value of Cancel = True
Private Sub vbWB1_WindowClosing(ByVal wbUID As Integer, ByVal IsChildWindow As Boolean, Cancel As Boolean)
On Error GoTo vbWB1_WindowClosing_Error
Cancel = False
Exit Sub
vbWB1_WindowClosing_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_WindowClosing of Form frmMyIE"
End Sub
标签： WebBrowser 图片 浏览器 下载 网页
vb 网页多窗口浏览器，支持多窗口，可以智能判断网页是否下载完毕。普通的WebBrowser 很难判断网页下载完毕，可以单独设置不显示图片、动画、脚本
好例子网口号：伸出你的我的手 — 分享！
小贴士
感谢您为本站写下的评论，您的评论对其它用户来说具有重要的参考价值，所以请认真填写。
- 类似“顶”、“沙发”之类没有营养的文字，对勤劳贡献的楼主来说是令人沮丧的反馈信息。
- 相信您也不想看到一排文字/表情墙，所以请不要反馈意义不大的重复字符，也请尽量不要纯表情的回复。
- 提问之前请再仔细看一遍楼主的说明，或许是您遗漏了。
- 请勿到处挖坑绊人、招贴广告。既占空间让人厌烦，又没人会搭理，于人于己都无利。
关于好例子网
本站旨在为广大IT学习爱好者提供一个非营利性互相学习交流分享平台。本站所有资源都可以被免费获取学习研究。本站资源来自网友分享，对搜索内容的合法性不具有预见性、识别性、控制性，仅供学习研究，请务必在下载后24小时内给予删除，不得用于其他任何用途，否则后果自负。基于互联网的特殊性，平台无法对用户传输的作品、信息、内容的权属或合法性、安全性、合规性、真实性、科学性、完整权、有效性等进行实质审查；无论平台是否已进行审查，用户均应自行承担因其传输的作品、信息、内容而可能或已经产生的侵权或权属纠纷等法律责任。本站所有资源不代表本站的观点或立场，基于网友分享，根据中国法律《信息网络传播权保护条例》第二十二与二十三条之规定，若资源存在侵权或相关问题请联系本站客服人员，点此联系我们。关于更多版权及免责申明参见 版权及免责申明
网友评论
我要评论