VERSION 5.00Object = "{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 EndEndAttribute VB_Name = "frmMyIE"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute 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 displayedPublic iCur As Integer'Two bool arrays to hold back forward values for each wbPrivate garrBackBtn() As BooleanPrivate garrForwardBtn() As BooleanDim TopDocumentComplete, isNewWin, isNewWinCreateDim curLabel As IntegerPrivate 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 = &H2Const MOUSEEVENTF_LEFTUP = &H4Const MOUSEEVENTF_MIDDLEDOWN = &H20Const MOUSEEVENTF_MIDDLEUP = &H40Const MOUSEEVENTF_MOVE = &H1Const MOUSEEVENTF_ABSOLUTE = &H8000Const MOUSEEVENTF_RIGHTDOWN = &H8Const MOUSEEVENTF_RIGHTUP = &H10Private 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 SubchkSource_Click_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure chkSource_Click of Form frmMyIE"End SubPrivate 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), """), ">", ">"), "<", "<") & LableStrEnd FunctionPrivate 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.ClearEnd FunctionPrivate 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 SubcmdLoadHtml_Click_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdLoadHtml_Click of Form frmMyIE"End SubPrivate Sub cmdPost_Click() On Error GoTo cmdPost_Click_Error'Choose POST or GET'If ? present then use GET'else POST raw dataDim iiD As Integer'Use POST'abstractvb supports post - no ? char in data segmentvbWB1.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 SubcmdPost_Click_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdPost_Click of Form frmMyIE"End SubPrivate 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 SubcmdsaveAsBmp_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 SubPrivate 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 SubcmdThumb_Click_Error: Screen.MousePointer = vbDefault MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdThumb_Click of Form frmMyIE"End SubPrivate 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 SubcmdZoom_Click_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdZoom_Click of Form frmMyIE"End SubPrivate Sub Combo1_KeyPress(KeyAscii As Integer) On Error Resume Next If KeyAscii = vbKeyReturn Then Command1_Click End IfEnd Sub'Simple navPrivate 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 SubCommand2_Click_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Command2_Click of Form frmMyIE"End SubPrivate Sub Command2_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)For i = 0 To 3Command2(i).BorderStyle = 0If i = Index ThenCommand2(Index).BorderStyle = 1End IfNextEnd SubPrivate Sub Command3_Click()dateStart = Now()Combo1.Text = "file:///C:/mytest.htm"Command1_ClickWhile TopDocumentComplete = FalseDoEventsSleep (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.cssTextIf .classname = "font14" Then.ClickWhile TopDocumentComplete = FalseDoEventsSleep (100)Wendallhtml = vbWB1.Document(iCur).documentElement.innerhtmltelstr = ddddddddddEnd 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 SubPrivate Sub SleepMe(timeshi)Set wsh = CreateObject("WScript.Shell")wsh.Run """c:\sleep.exe"" " & timeshi, 0, TrueSet wsh = NothingMsgBox "sssss"End SubPrivate Sub Form_Activate()LabelP(0).BackColor = &HF0F0F0End 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 SubForm_Load_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Form_Load of Form frmMyIE"End SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)For i = 0 To 3Command2(i).BorderStyle = 0NextEnd SubPrivate Sub Form_Unload(Cancel As Integer) On Error GoTo Form_Unload_Error Unload frmSandBox Unload frmFindText Exit SubForm_Unload_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Form_Unload of Form frmMyIE"End SubPrivate 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 SubPrivate Sub Label3_DblClick()isNewWin = TrueisNewWinCreate = 1Label3.ZOrder 1Call GoWebUrl vbWB1.NavigateSimple iCur, "about:blank"End SubPrivate Sub LabelP_DblClick(Index As Integer)vbWB1.NavigateSimple CInt(LabelP(Index).Tag), "about:blank" zuihouYiGe = GetLabelPnum()If zuihouYiGe > 1 ThenFor i = Index 1 To LabelP.UBoundLabelP(i).Left = LabelP(i).Left - LabelP(i).WidthNextLabelP(Index).Visible = FalseEnd 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 IfIf LabelP(Index).Tag = iCur Then focusWEB 0End IfEnd SubPrivate 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 = IndexPopupMenu rightmenuwebElse 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 IfEnd IfEnd SubPrivate 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 SubmnuWB_Click_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure mnuWB_Click of Form frmMyIE"End SubPrivate Sub rightmenuweb2_Click()LabelP_DblClick curLabelEnd SubPrivate 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 SubvbWB1_CommandStateChange_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_CommandStateChange of Form frmMyIE"End SubPrivate 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 SubvbWB1_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 SubvbWB1_OnGetOptionKeyPath_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnGetOptionKeyPath of Form frmMyIE"End SubPrivate Sub vbWB1_OnGetOverrideKeyPath(ByVal wbUID As Integer, sRegistryOverrideKeyPath As String) On Error GoTo vbWB1_OnGetOverrideKeyPath_Error AddToLog ">>>vbWB1_OnGetOverrideKeyPath" Exit SubvbWB1_OnGetOverrideKeyPath_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnGetOverrideKeyPath of Form frmMyIE"End SubPrivate 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 SubvbWB1_OnPostDataAvailable_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnPostDataAvailable of Form frmMyIE"End SubPrivate Sub vbWB1_OnPostEnd(ByVal PostUID As Integer, ByVal sURL As String) On Error GoTo vbWB1_OnPostEnd_Error AddToLog ">>>vbWB1_OnPostEnd" & vbCrLf & PostUID Exit SubvbWB1_OnPostEnd_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnPostEnd of Form frmMyIE"End SubPrivate 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 SubvbWB1_OnPostError_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnPostError of Form frmMyIE"End Sub'CancelPost, default = FalsePrivate 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 SubvbWB1_OnPostOnProgress_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnPostOnProgress of Form frmMyIE"End SubPrivate 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 SubvbWB1_OnPostResponse_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnPostResponse of Form frmMyIE"End SubPrivate 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 SubvbWB1_OnWBDragEnter_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnWBDragEnter of Form frmMyIE"End SubPrivate Sub vbWB1_OnWBDragLeave(ByVal wbUID As Integer) On Error GoTo vbWB1_OnWBDragLeave_Error AddToLog ">>>vbWB1_OnWBDragLeave" Exit SubvbWB1_OnWBDragLeave_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnWBDragLeave of Form frmMyIE"End SubPrivate 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 SubvbWB1_OnWBDragOver_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnWBDragOver of Form frmMyIE"End SubPrivate 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 SubvbWB1_OnWBDrop_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_OnWBDrop of Form frmMyIE"End Sub'Multiple filesPrivate 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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 IfmnuWB(wbUID - 1).Caption = CStr(objDoc.URL) Exit SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_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 SubvbWB1_ShowMessage_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_ShowMessage of Form frmMyIE"End SubFunction 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 FunctionFunction 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 FunctionPrivate 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 - 1Call GoWebUrl vbWB1.RegisterAsBrowser(iCur) = True Set ppDisp = vbWB1.ObjectWB(iCur) vbWB1.PlaceWBOnTop wbUID vbWB1.SetFocusW wbUID AddToLog ">>>New Winodw2>>>" Exit SubvbWB1_NewWindow2_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_NewWindow2 of Form frmMyIE"End SubPrivate 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 SubvbWB1_BeforeNavigate2_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_BeforeNavigate2 of Form frmMyIE"End Sub'Default, Cancel = truePrivate 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 SubvbWB1_NavigateError_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_NavigateError of Form frmMyIE"End SubPrivate Sub vbWB1_StatusTextChange(ByVal wbUID As Integer, ByVal Text As String) On Error GoTo vbWB1_StatusTextChange_Error Label1.Caption = Text Exit SubvbWB1_StatusTextChange_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_StatusTextChange of Form frmMyIE"End SubPrivate Sub vbWB1_TitleChange(ByVal wbUID As Integer, ByVal Text As String) On Error GoTo vbWB1_TitleChange_ErrorCaption = Text If Text = "" Then Caption = "MyIE浏览器" End If LabelP(wbUID - 1).Caption = vbCrLf & GotTopic(Text, 14) & "..." Exit SubvbWB1_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 SubcmdSandBox_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 FunctionSub 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 NextEnd 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 SubPrivate Sub Command1_Click() On Error GoTo Command1_Click_ErrorisNewWin = False'isNewWinCreate = 2Call GoWebUrl vbWB1.NavigateSimple iCur, Combo1.Text Exit SubCommand1_Click_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Command1_Click of Form frmMyIE"End SubPublic 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 SubAddToLog_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 controlPrivate 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 SubchkHeaders_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 SubvbWB1_WBProcessUrlAction_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_WBProcessUrlAction of Form frmMyIE"End Sub'Default value of Cancel = TruePrivate Sub vbWB1_WindowClosing(ByVal wbUID As Integer, ByVal IsChildWindow As Boolean, Cancel As Boolean) On Error GoTo vbWB1_WindowClosing_Error Cancel = False Exit SubvbWB1_WindowClosing_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure vbWB1_WindowClosing of Form frmMyIE"End Sub
评论