浏览器

开发平台：
Visual Basic

cWebBrowser.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cWebBrowser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'---------------------------------------------------------------------------------------
' Module    : cWebBrowser
' DateTime  : 2005-8-11 12:38
' Author    : Lingll
' Purpose   :
' 2005-8-11 :   Implemented IDownloadManager
'               add DownloadBegin event
' 200x-x-xx :   Implemented IOleCommandTarget
'---------------------------------------------------------------------------------------
'*********************************************************************************************
'
' Customizing the WebBrowser control
'
' Custom WebBrowser control
'
'*********************************************************************************************
'
' Author: Eduardo A. Morcillo
' E-Mail: e_morcillo@yahoo.com
' Web Page: http://www.domaindlx.com/e_morcillo
'
' Distribution: You can freely use this code in your own applications but you
'               can't publish this code in a web site, online service, or any
'               other media, without my express permission.
'
' Usage: at your own risk.
'
' Tested with:
'              Windows Me
'              VB6 + SP5
'              IE 6.0
'
' History:
'           09/26/2001 - Fixed: Mouse click doesn't set focus
'           09/13/2001 - Added: BrowseMode property.
'                      - Added: The control now implements IDocHostShowUI
'                      - Fixed: Can't write on form fields
'           05/04/2001 - Added the SecutiryZone property.
'                      - Fixed: Properties are not saved.
'           05/03/2001 - The class was converted to control.
'                      - Implemented IServiceProvider to allow more
'                        customizations.
'                      - Implemented IInternetSecurityManager to
'                        control security.
'           04/27/2001 - Added the UserAgent and DownloadCtrl properties
'           06/06/2000 - ExecCommand event was added.
'           03/25/2000 - This code was released.
'
'*********************************************************************************************
Option Explicit
' Implement IDocHostUIHandler to receive
' notifications from WebBrowser control
Implements olelib.IDocHostUIHandler
Implements olelib.IDocHostShowUI
' Implement IDropTarget to get OLE
' drag & drop events
Implements olelib.IDropTarget
' Implement IServiceProvider
Implements olelib2.IServiceProvider
' Implement IInternetSecurityManager to
' use security zones with this control
Implements olelib.IInternetSecurityManager
' Implement site interfaces to host the WB control
Implements olelib.IOleClientSite
Implements olelib2.IOleInPlaceSite
'主要目的是不显示脚本错误对话框
Implements olelib2.IOleCommandTarget
'处理下载事件
Implements olelib.IDownloadManager
' ===== Private members =====
Private WithEvents m_oWebBrowser As SHDocVw.WebBrowser               ' WebBrowser control
Attribute m_oWebBrowser.VB_VarHelpID = -1
Private WithEvents m_oDoc As HTMLDocument
Attribute m_oDoc.VB_VarHelpID = -1
Private m_oDataObject As DataObjectWB                     ' Custom DataObject
Private m_oZM As olelib.IInternetZoneManager              ' ZoneManager object
Private m_sUserAgent As String                            ' UserAgent
Private m_lDownloadCtrl As DownloadCtrlFlags              ' Download control flags
Private m_bBrowseMode As Boolean                          ' BrowseMode
'Private m_bGotFocus As Boolean
' ===== Public members =====
Public HostInfo As HostFlags             ' Host flags
Public SecurityZone As SecurityZones     ' Security Zone used by this control
Public MessageCallback As WBMessages
' ===== Public enums =====
Enum SecurityZones
   LocalMachine = URLZONE.URLZONE_LOCAL_MACHINE
   Intranet = URLZONE.URLZONE_INTRANET
   Internet = URLZONE.URLZONE_INTERNET
   Trusted = URLZONE.URLZONE_TRUSTED
   Untrusted = URLZONE.URLZONE_UNTRUSTED
End Enum
Public Enum HostFlags
   ' MSHTML will not allow selection
   ' of the text in the form.
   hfDialog = DOCHOSTUIFLAG_DIALOG
   ' MSHTML will not add the Help menu
   ' item to the container's menu.
   hfDisableHelpMenu = DOCHOSTUIFLAG_DISABLE_HELP_MENU
   ' MSHTML does not use 3-D borders.
   hfNo3DBorder = DOCHOSTUIFLAG_NO3DBORDER
   ' MSHTML does not have scroll bars.
   hfNoScroll = DOCHOSTUIFLAG_SCROLL_NO
   ' MSHTML will not execute any
   ' script when loading pages.
   hfDisableScripInactive = DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE
   ' MSHTML will open a site in
   ' a new window when a link is
   ' clicked rather than browse to
   ' the new site using the same
   ' browser window.
   hfBrowseNew = DOCHOSTUIFLAG_OPENNEWUI
   ' Not implemented.
   hfDisableOffScreen = DOCHOSTUIFLAG_DISABLE_OFFSCREEN
   ' MSHTML will use flat scroll bars
   ' for any UI it displays.
   hfFlatScroll = DOCHOSTUIFLAG_FLAT_SCROLLBAR
   ' MSHTML will insert the <DIV> tag
   ' if a return is entered in edit mode.
   ' Without this flag, MSHTML will use
   ' the <P> tag.
   hfDivBlock = DOCHOSTUIFLAG_DIV_BLOCKDEFAULT
   ' MSHTML will only become UI active
   ' if the mouse is clicked in the
   ' client area of the window. It will
   ' not become UI active if the mouse
   ' is clicked on a nonclient area, such
   ' as a scroll bar.
   hfActiveClientHit = DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY
   ' MSHTML will consult the host
   ' before retrieving a behavior
   ' from the URL specified on the page.
   hfOverrideBehaviorFactory = DOCHOSTUIFLAG_OVERRIDEBEHAVIORFACTORY
   ' This flag was added to Microsoft(r)
   ' Internet Explorer 5 to provide font
   ' selection compatibility for Microsoft(r)
   ' Outlook(r) Express. If the flag is enabled,
   ' the displayed characters are inspected
   ' to determine whether the current font
   ' supports the code page. If disabled, the
   ' current font is used, even if it does
   ' not contain a glyph for the character.
   ' Note This flag assumes that the user is
   ' using Internet Explorer 5 and Outlook
   ' Express 4.0.
   hfCodePageLinkedFonts = DOCHOSTUIFLAG_CODEPAGELINKEDFONTS
   ' This flag was added to Internet Explorer
   ' 5 to control how nonnative URLs are
   ' transmitted over the Internet. Nonnative
   ' refers to characters outside the
   ' multibyte encoding of the URL. If this
   ' flag is set, the URL is not submitted
   ' to the server in UTF-8 encoding.
   hfDisableUTF8 = DOCHOSTUIFLAG_URL_ENCODING_DISABLE_UTF8
   ' This flag was added to Internet Explorer
   ' 5 to control how nonnative URLs are
   ' transmitted over the Internet. Nonnative
   ' refers to characters outside the
   ' multibyte encoding of the URL. If this
   ' flag is set, the URL is submitted
   ' to the server in UTF-8 encoding.
   hfEnableUTF8 = DOCHOSTUIFLAG_URL_ENCODING_ENABLE_UTF8
   ' This flag enables the AutoComplete
   ' feature for forms in the hosted
   ' browser. The Intelliforms feature will
   ' only be turned on if the user has
   ' previously enabled it. If the user has
   ' turned the AutoComplete feature off
   ' for forms, it will be off whether
   ' this flag is specified or not.
   hfEnableFormAutocomplete = DOCHOSTUIFLAG_ENABLE_FORMS_AUTOCOMPLETE
   ' This flag enables the host to specify
   ' that navigation should happen in place.
   ' This means that applications hosting
   ' MSHTML directly can specify that
   ' navigation happen in the application's
   ' window. For instance, if this flag is
   ' set, you can click a link in HTML mail
   ' and navigate in the mail instead of
   ' opening a new Internet Explorer window.
   hfInPlaceNavigation = DOCHOSTUIFLAG_ENABLE_INPLACE_NAVIGATION
   ' During initialization, the host can set
   ' this flag to enable input method editor
   ' (IME) reconversion, allowing computer
   ' users to employ IME reconversion while
   ' browsing Web pages. An input method
   ' editor is a program that allows users to
   ' enter complex characters and symbols,
   ' such as Japanese Kanji characters, using
   ' a standard keyboard. For more information,
   ' see the International Features reference
   ' in the Base Services section of the
   ' Platform SDK.
   hfEnableIME = DOCHOSTUIFLAG_IME_ENABLE_RECONVERSION
   
   hfDefault = hfEnableFormAutocomplete Or hfEnableIME
End Enum
Public Enum DownloadCtrlFlags
   DLCTL_DLIMAGES = &H10&
   DLCTL_VIDEOS = &H20&
   DLCTL_BGSOUNDS = &H40&
   DLCTL_NO_SCRIPTS = &H80&
   DLCTL_NO_JAVA = &H100&
   DLCTL_NO_RUNACTIVEXCTLS = &H200&
   DLCTL_NO_DLACTIVEXCTLS = &H400&
   DLCTL_DOWNLOADONLY = &H800&
   DLCTL_NO_FRAMEDOWNLOAD = &H1000&
   DLCTL_RESYNCHRONIZE = &H2000&
   DLCTL_PRAGMA_NO_CACHE = &H4000&
   DLCTL_NO_BEHAVIORS = &H8000&
   DLCTL_NO_METACHARSET = &H10000
   DLCTL_URL_ENCODING_DISABLE_UTF8 = &H20000
   DLCTL_URL_ENCODING_ENABLE_UTF8 = &H40000
   DLCTL_FORCEOFFLINE = &H10000000
   DLCTL_NO_CLIENTPULL = &H20000000
   DLCTL_SILENT = &H40000000
   DLCTL_OFFLINE = &H80000000
   DLCTL_Default = DLCTL_BGSOUNDS Or DLCTL_DLIMAGES Or DLCTL_VIDEOS ' Or DLCTL_SILENT
End Enum
' ===== Events =====
Event ExecCommand(nCmdID As olelib.WBIDM)
Event GetExternal(External As Object)
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Event OleDragDrop(ByVal Data As DataObjectWB, ByVal KeyState As Long, _
                  ByVal x As Long, ByVal y As Long, Effect As Long)
Event OLEDragOver(ByVal Data As DataObjectWB, ByVal KeyState As Long, _
                  ByVal x As Long, ByVal y As Long, Effect As Long)
Event OLEDragEnter(ByVal Data As DataObjectWB, ByVal KeyState As Long, _
                  ByVal x As Long, ByVal y As Long, Effect As Long)
Event OLEDragLeave()
Event ProcessAction(ByVal url As String, ByVal Action As olelib.URLACTIONS, _
                   Policy As URLPOLICIES)
Event ShowContextMenu(ByVal ItemType As ContextMenuTarget, ByVal HTMLElement As Object, cancel As Boolean)
Event TranslateURL(url As String)
'开始下载,>=ie5.5
Public Event DownloadBegin(url$, ByRef cancel&)
Private WithEvents vFrmWeb As Form
Attribute vFrmWeb.VB_VarHelpID = -1
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_CHAR = &H102
'是否已经创建
Private Created As Boolean
'Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
'
' Returns whether the control is in browse or edit mode
'
' This property must have DISPIP = -709 (AMBIENT_USERMODE)
'
Public Property Get BrowseMode() As Boolean
Attribute BrowseMode.VB_UserMemId = -709
   BrowseMode = m_bBrowseMode
End Property
Public Property Let BrowseMode(New_BrowseMode As Boolean)
Dim oOC As IOleControl
   m_bBrowseMode = New_BrowseMode
   ' Get the WB IOleControl
   Set oOC = m_oWebBrowser
   ' Notify the WB control that
   ' the property was changed
   oOC.OnAmbientPropertyChange AMBIENT_DISPIDS.DISPID_AMBIENT_USERMODE
End Property
'
' DownloadCtrl
'
' Returns the download control flags. This property
' is called by the WB control to get the flags.
'
' Be sure that the property ID is set to -5512.
'
Public Property Get DownloadCtrl() As DownloadCtrlFlags
Attribute DownloadCtrl.VB_UserMemId = -5512
   DownloadCtrl = m_lDownloadCtrl
End Property
Public Property Let DownloadCtrl(ByVal NewFlags As DownloadCtrlFlags)
Dim oOC As IOleControl
   m_lDownloadCtrl = NewFlags
If Created Then
   ' Get the WB IOleControl
   Set oOC = m_oWebBrowser
   ' Notify the WB control that
   ' the property was changed
   oOC.OnAmbientPropertyChange -5512
End If
End Property
'
' Exec
'
' Executes an OLE command
'
Public Sub Exec(ByVal CMDID As WBIDM, Optional ByVal CMDOPT As OLECMDEXECOPT = OLECMDEXECOPT_DODEFAULT, Optional ByVal VarIn As Variant, Optional VarOut As Variant)
Dim oCommandTarget As olelib.IOleCommandTarget      ' WebBrowser's IOleCommandTarget interface
   Set oCommandTarget = m_oWebBrowser
   ' Execute the command
   oCommandTarget.Exec CGID_HTML, CMDID, CMDOPT, VarIn, VarOut
End Sub
'
' pvAddRefMe
'
' Increments the reference count of this control
'
Private Sub pvAddRefMe()
Dim oUnk As olelib.IUnknown
   Set oUnk = Me
   oUnk.AddRef
End Sub
'
' QueryStatus
'
' Queries an OLE command status
'
Public Function QueryStatus(ByVal CMDID As WBIDM, Optional name As String) As Long
Dim uOLECMD As OLECMD
Dim uCMDTEXT As OLECMDTEXT
Dim oCommandTarget As olelib.IOleCommandTarget      ' WebBrowser's IOleCommandTarget interface
   Set oCommandTarget = m_oWebBrowser
   ' Initialize the UDTs
   uOLECMD.CMDID = CMDID
   uCMDTEXT.cmdtextf = OLECMDTEXTF_NAME
   uCMDTEXT.cwBuf = 260
   ' Query the status
   oCommandTarget.QueryStatus CGID_HTML, 1, uOLECMD, uCMDTEXT
   ' Return the status
   QueryStatus = uOLECMD.cmdf
   ' Return the name
   name = uCMDTEXT.rgwz
   name = Left$(name, InStr(name, vbNullChar) - 1)
End Function
'
' pvCreateWBControl
'
' Creates the WebBrowser control
'
Private Sub pvCreateWBControl()
Dim oOleObj As IOleObject
Dim oUnk As olelib.IUnknown
'Dim oFrame As IOleInPlaceFrame
Dim oOC As IOleControl
Dim tMSG As olelib.MSG
Dim tRect As olelib.RECT
   ' Create the WebBrowser control
   CoCreateInstance CLSID_WebBrowser, Nothing, CLSCTX_INPROC_SERVER, IID_IUnknown, oUnk
   
   ' Get the WebBrowser interface
   Set m_oWebBrowser = oUnk
   
   ' Get the IOleObject interface
   Set oOleObj = m_oWebBrowser
   
   ' Set the client site
   oOleObj.SetClientSite Me
   
   ' Activate the document
   oOleObj.DoVerb OLEIVERB_UIACTIVATE, tMSG, Me, 0, vFrmWeb.hWnd, tRect
Created = True
   ' Force the WB control to get the
   ' UA and download control properties
   Set oOC = oOleObj
   oOC.OnAmbientPropertyChange -5513
   oOC.OnAmbientPropertyChange -5512
   
End Sub
'
' UserAgent
'
' Returns the UserAgent. This property
' is called by the WB control to get the UA
' that it'll send to the server.
'
' Be sure that the property ID is set to -5513.
'
Public Property Get UserAgent() As String
Attribute UserAgent.VB_UserMemId = -5513
   UserAgent = m_sUserAgent
End Property
Public Property Let UserAgent(ByVal New_UA As String)
Dim oOC As IOleControl
   m_sUserAgent = New_UA
If Created Then
   ' Get the WB IOleControl
   Set oOC = m_oWebBrowser
   ' Notify the WB control that
   ' the property was changed
   oOC.OnAmbientPropertyChange -5513
End If
End Property
Private Sub Class_Initialize()
Call IniVars
End Sub
Private Sub Class_Terminate()
'Dim tUr As olelib.IUnknown
'Set tUr = Me
'tUr.Release
End Sub
Private Sub IDocHostShowUI_ShowHelp(ByVal hWnd As Long, ByVal pszHelpFile As Long, ByVal uCommand As Long, ByVal dwData As Long, ByVal x As Long, ByVal y As Long, ByVal pDispatchObjectHit As Object)
Dim rtn As Long
'Debug.Print "showhelp"
If Not MessageCallback Is Nothing Then
   rtn = MessageCallback.ShowHelp(SysAllocString(pszHelpFile), uCommand, dwData, x, y, pDispatchObjectHit)
End If
End Sub
Private Function IDocHostShowUI_ShowMessage(ByVal hWnd As Long, ByVal lpszText As Long, ByVal lpszCaption As Long, ByVal dwType As Long, ByVal lpszHelpFile As Long, ByVal dwHelpContext As Long) As Long
Debug.Print "showmessage"
Dim rtn As Long
Dim tText As String
Dim tActiveX As Boolean
tText = SysAllocString(lpszText)
tActiveX = (InStr(tText, " ActiveX ") > 0)
'debug.Print tActiveX
If ((dwType And vbOKOnly) = vbOKOnly) And tActiveX Then
Else
    If MessageCallback Is Nothing Then
        'If (dwType And vbOKOnly) = vbOKOnly Then
        '    MessageBox vFrmWeb.hwnd, SysAllocString(lpszText), App.Title, dwType
        'Else
            rtn = MsgBox(SysAllocString(lpszText), dwType, App.Title, SysAllocString(lpszHelpFile), dwHelpContext)
        'End If
    Else
        rtn = MessageCallback.ShowMessage(SysAllocString(lpszText), dwType, App.Title, SysAllocString(lpszHelpFile), dwHelpContext)
    End If
End If
IDocHostShowUI_ShowMessage = rtn
End Function
Private Sub IDownloadManager_Download(ByVal pmk As olelib.IMoniker, ByVal pbc As olelib.IBindCtx, ByVal dwBindVerb As Long, ByVal grfBINDF As Long, pbindinfo As olelib.BINDINFO, ByVal pszHeaders As Long, ByVal pszRedir As Long, ByVal uiCP As Long)
Dim turl$
Dim cancel&
turl = SysAllocString(pmk.GetDisplayName(pbc, Nothing))
RaiseEvent DownloadBegin(turl, cancel)
If cancel = 1 Then
Else
    Err.Raise S_OK
End If
End Sub
Private Sub IInternetSecurityManager_GetSecurityId( _
   ByVal pwszUrl As Long, _
   ByVal pbSecurityId As Long, _
   pcbSecurityId As Long, _
   ByVal dwReserved As Long)
   ' Default action
   Err.Raise INET_E_DEFAULT_ACTION
End Sub
Private Function IInternetSecurityManager_GetSecuritySite() As olelib.IInternetSecurityMgrSite
   ' Default action
   Err.Raise INET_E_DEFAULT_ACTION
End Function
Private Sub IInternetSecurityManager_GetZoneMappings(ByVal dwZone As Long, ppenumString As olelib.IEnumString, ByVal dwFlags As Long)
   ' Default action
   Err.Raise INET_E_DEFAULT_ACTION
End Sub
Private Sub IInternetSecurityManager_MapUrlToZone(ByVal pwszUrl As Long, pdwZone As Long, ByVal dwFlags As Long)
   ' Default action
   Err.Raise INET_E_DEFAULT_ACTION
End Sub
Private Sub IInternetSecurityManager_ProcessUrlAction( _
      ByVal pwszUrl As Long, _
      ByVal dwAction As URLACTIONS, _
      ByVal pPolicy As Long, _
      ByVal cbPolicy As Long, _
      pContext As Byte, _
      ByVal cbContext As Long, _
      ByVal dwFlags As olelib.PUAF, _
      ByVal dwReserved As Long)
Dim lPolicy As olelib.URLPOLICIES
Dim abPolicy(0 To 3) As Byte
'debug.Print dwAction
   ' Get the policy for the
   ' control security zone
   m_oZM.GetZoneActionPolicy SecurityZone, dwAction, abPolicy(0), 4&, URLZONEREG_DEFAULT
   MoveMemory lPolicy, abPolicy(0), 4&
   ' Ask the container for a policy.
   ' This allows the container to
   ' overwrite the policies for the
   ' selected security zone
   RaiseEvent ProcessAction(SysAllocString(pwszUrl), dwAction, lPolicy)
   ' Copy the policy to the pointer
   MoveMemory ByVal pPolicy, lPolicy, 4&
End Sub
Private Sub IInternetSecurityManager_QueryCustomPolicy(ByVal pwszUrl As Long, guidKey As olelib.UUID, ppPolicy As Long, pcbPolicy As Long, pContext As Byte, ByVal cbContext As Long, Optional ByVal dwReserved As Long = 0&)
   ' Default action
   Err.Raise INET_E_DEFAULT_ACTION
End Sub
Private Sub IInternetSecurityManager_SetSecuritySite(ByVal pSite As olelib.IInternetSecurityMgrSite)
   ' Default action
   Err.Raise INET_E_DEFAULT_ACTION
End Sub
Private Sub IInternetSecurityManager_SetZoneMapping(ByVal dwZone As Long, ByVal lpszPattern As Long, ByVal dwFlags As olelib.SZM_FLAGS)
   ' Default action
   Err.Raise INET_E_DEFAULT_ACTION
End Sub
Private Function IOleClientSite_GetContainer() As olelib.IOleContainer
   Err.Raise E_NOTIMPL
End Function
Private Function IOleClientSite_GetMoniker(ByVal dwAssign As olelib.OLEGETMONIKER, ByVal dwWhichMoniker As olelib.OLEWHICHMK) As olelib.IMoniker
   Err.Raise E_NOTIMPL
End Function
Private Sub IOleClientSite_OnShowWindow(ByVal fShow As olelib.bool)
   Err.Raise E_NOTIMPL
End Sub
Private Sub IOleClientSite_RequestNewObjectLayout()
   Err.Raise E_NOTIMPL
End Sub
Private Sub IOleClientSite_SaveObject()
End Sub
Private Sub IOleClientSite_ShowObject()
   Err.Raise E_NOTIMPL
End Sub
Private Sub IOleCommandTarget_Exec(pguidCmdGroup As olelib.UUID, _
        ByVal nCmdID As Long, ByVal nCmdexecopt As olelib.OLECMDEXECOPT, _
        pvaIn As Variant, pvaOut As Variant)
'Debug.Print "cmd", nCmdID
If VarPtr(pguidCmdGroup) <> 0 Then
    If IsEqualGUID(pguidCmdGroup, CGID_DocHostCommandHandler) = 1 Then
        Select Case nCmdID
            Case OLECMDID_SHOWSCRIPTERROR
            
            Case Else
                Err.Raise OLECMDERR_E_NOTSUPPORTED
        End Select
    Else
        Err.Raise OLECMDERR_E_UNKNOWNGROUP
    End If
        
Else
    Err.Raise OLECMDERR_E_UNKNOWNGROUP
End If
End Sub
Private Sub IOleCommandTarget_QueryStatus(pguidCmdGroup As olelib.UUID, ByVal cCmds As Long, prgCmds As olelib.OLECMD, pCmdText As olelib.OLECMDTEXT)
End Sub
Private Sub IOleInPlaceSite_CanInPlaceActivate()
End Sub
Private Sub IOleInPlaceSite_ContextSensitiveHelp(ByVal fEnterMode As olelib.bool)
End Sub
Private Sub IOleInPlaceSite_DeactivateAndUndo()
'debug.Print "IOleInPlaceSite_DeactivateAndUndo"
End Sub
Private Sub IOleInPlaceSite_DiscardUndoState()
End Sub
Private Function IOleInPlaceSite_GetWindow() As Long
   IOleInPlaceSite_GetWindow = vFrmWeb.hWnd
End Function
Private Sub IOleInPlaceSite_GetWindowContext(ppFrame As olelib.IOleInPlaceFrame, ppDoc As olelib.IOleInPlaceUIWindow, lprcPosRect As olelib.RECT, lprcClipRect As olelib.RECT, lpFrameInfo As olelib.OLEINPLACEFRAMEINFO)
   
   Set ppFrame = vFrmWeb ' Me
   Set ppDoc = Me
   
   lpFrameInfo.hwndFrame = vFrmWeb.hWnd
   
End Sub
Private Sub IOleInPlaceSite_OnInPlaceActivate()
    'debug.Print "IOleInPlaceSite_OnInPlaceActivate"
End Sub
Private Sub IOleInPlaceSite_OnInPlaceDeactivate()
'debug.Print "IOleInPlaceSite_OnInPlaceDeactivate"
End Sub
Private Sub IOleInPlaceSite_OnPosRectChange(lprcPosRect As olelib.RECT)
End Sub
Private Sub IOleInPlaceSite_OnUIActivate()
'Debug.Print "IOleInPlaceSite_OnUIActivate"
vFrmWeb.SetFocus
End Sub
Private Sub IOleInPlaceSite_OnUIDeactivate(ByVal fUndoable As olelib.bool)
'debug.Print "IOleInPlaceSite_OnUIDeactivate", fUndoable
End Sub
Private Sub IOleInPlaceSite_Scroll(ByVal scrollX As Long, ByVal scrollY As Long)
Debug.Print "IOleInPlaceSite_Scroll"
End Sub
Private Sub IServiceProvider_QueryService(guidService As olelib.UUID, riid As olelib.UUID, ppvObject As Long)
If IsEqualGUID(guidService, IID_IInternetSecurityManager) Then
    Dim oISM As IInternetSecurityManager
    
    ' Increment the reference count
    pvAddRefMe
    
    Set oISM = Me
    
    ' Return this object
    MoveMemory ppvObject, oISM, 4&
    
    'Err.Raise S_OK
Else
    If IsEqualGUID(guidService, IID_IDownloadManager) And _
        IsEqualGUID(riid, IID_IDownloadManager) Then
      
        Dim oDM As IDownloadManager
        pvAddRefMe
        
        Set oDM = Me
        
        MoveMemory ppvObject, oDM, 4&
    
    Else
        ' The service or interface is
        ' not supported
        Err.Raise E_NOINTERFACE
    End If
End If
End Sub
Private Sub m_oDoc_onactivate()
   On Error Resume Next
   
   ' Set the focus when the document is activated
   'If m_bGotFocus = False Then vFrmWeb.SetFocus
   
End Sub
Private Sub m_oWebBrowser_NavigateComplete2(ByVal pDisp As Object, url As Variant)
   
   On Error Resume Next
   
   ' Get the document
   Set m_oDoc = m_oWebBrowser.Document
   
End Sub
Private Sub IDocHostUIHandler_EnableModeless(ByVal fEnable As olelib.bool)
   Err.Raise E_NOTIMPL
End Sub
Private Function IDocHostUIHandler_FilterDataObject(ByVal pDO As olelib.IDataObject) As olelib.IDataObject
   Err.Raise E_NOTIMPL
End Function
Private Function IDocHostUIHandler_GetDropTarget(ByVal pDropTarget As olelib.IDropTarget) As olelib.IDropTarget
   ' Replace the IDropTarget interface
   ' of the browser object
   Set IDocHostUIHandler_GetDropTarget = Me
End Function
Private Function IDocHostUIHandler_GetExternal() As Object
    Set IDocHostUIHandler_GetExternal = vFrmWeb
    'RaiseEvent GetExternal(IDocHostUIHandler_GetExternal)
End Function
Private Sub IDocHostUIHandler_GetHostInfo(pInfo As olelib.DOCHOSTUIINFO)
   pInfo.dwFlags = HostInfo
   pInfo.dwDoubleClick = DOCHOSTUIDBLCLK_DEFAULT
End Sub
Private Sub IDocHostUIHandler_GetOptionKeyPath(pOLESTRchKey As Long, ByVal dw As Long)
   Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_GetOverrideKeyPath(pchKey As Long, ByVal dw As Long)
   Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_HideUI()
'   Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_OnDocWindowActivate(ByVal fActivate As olelib.bool)
'   Err.Raise S_OK 'E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_OnFrameWindowActivate(ByVal fActivate As olelib.bool)
'debug.Print "IDocHostUIHandler_OnFrameWindowActivate", fActivate
'   Err.Raise S_OK 'E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_ResizeBorder(prcBorder As olelib.RECT, ByVal pUIWindow As olelib.IOleInPlaceUIWindow, ByVal fRameWindow As olelib.bool)
'Debug.Print "uihandle resieze"
'   Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_ShowContextMenu(ByVal dwContext As olelib.ContextMenuTarget, pPOINT As olelib.POINT, ByVal pCommandTarget As olelib.IOleCommandTarget, ByVal HTMLTagElement As Object)
Dim bCancel As Boolean
   ' Raise the event
   RaiseEvent ShowContextMenu(dwContext, HTMLTagElement, bCancel)
   ' If bCancel = False show
   ' the context menu
   If Not bCancel Then Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_ShowUI(ByVal dwID As Long, ByVal pActiveObject As olelib.IOleInPlaceActiveObject, ByVal pCommandTarget As olelib.IOleCommandTarget, ByVal pFrame As olelib.IOleInPlaceFrame, ByVal pDoc As olelib.IOleInPlaceUIWindow)
'   Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_TranslateAccelerator(lpmsg As olelib.MSG, pguidCmdGroup As olelib.UUID, ByVal nCmdID As Long)
Dim Shift As Integer, Char As Integer
   If nCmdID = 0 Then
      ' Raise keyboard events
      Select Case lpmsg.message
         Case WM_CHAR
            Char = lpmsg.wParam
            RaiseEvent KeyPress(Char)
            If Char = 0 Then Exit Sub
         Case WM_KEYDOWN
            If GetAsyncKeyState(vbKeyShift) Then Shift = Shift Or vbShiftMask
            If GetAsyncKeyState(vbKeyMenu) Then Shift = Shift Or vbAltMask
            If GetAsyncKeyState(vbKeyControl) Then Shift = Shift Or vbCtrlMask
            Char = lpmsg.wParam
            RaiseEvent KeyDown(Char, Shift)
            If Char = 0 Then Exit Sub
         Case WM_KEYUP
            If GetAsyncKeyState(vbKeyShift) Then Shift = Shift Or vbShiftMask
            If GetAsyncKeyState(vbKeyMenu) Then Shift = Shift Or vbAltMask
            If GetAsyncKeyState(vbKeyControl) Then Shift = Shift Or vbCtrlMask
            Char = lpmsg.wParam
            RaiseEvent KeyUp(Char, Shift)
            If Char = 0 Then Exit Sub
      End Select
   Else
      ' Check for the command group
      ' and raise the ExecCommand event
      If IsEqualGUID(pguidCmdGroup, CGID_HTML) Then
         RaiseEvent ExecCommand(nCmdID)
         If nCmdID = 0 Then Exit Sub
      End If
   End If
   ' Let the WB process this
   ' accelerator
    Err.Raise E_NOTIMPL
End Sub
Private Function IDocHostUIHandler_TranslateUrl(ByVal dwTranslate As Long, ByVal pchURLIn As Long) As Long
'Debug.Print "IDocHostUIHandler_TranslateUrl:"
Dim sURL As String
   ' Get the URL from the pointer
   sURL = SysAllocString(pchURLIn)
   ' Raise the event
   RaiseEvent TranslateURL(sURL)
   
   ' Return the new URL
   IDocHostUIHandler_TranslateUrl = Str2Ptr(sURL)
End Function
Private Sub IDocHostUIHandler_UpdateUI()
'   Err.Raise E_NOTIMPL
End Sub
Private Sub IDropTarget_DragEnter(ByVal pDataObj As olelib.IDataObject, ByVal grfKeyState As Long, ByVal ptX As Long, ByVal pyY As Long, pdwEffect As olelib.DROPEFFECTS)
   ' Create the data object
   Set m_oDataObject = New DataObjectWB
   ' Set the IDataObject property
   Set m_oDataObject.IDataObject = pDataObj
   RaiseEvent OLEDragEnter(m_oDataObject, grfKeyState, ptX, pyY, pdwEffect)
End Sub
Private Sub IDropTarget_DragLeave()
   RaiseEvent OLEDragLeave
   ' Destroy the data object
   Set m_oDataObject = Nothing
End Sub
Private Sub IDropTarget_DragOver(ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As olelib.DROPEFFECTS)
   RaiseEvent OLEDragOver(m_oDataObject, grfKeyState, ptX, ptY, pdwEffect)
End Sub
Private Sub IDropTarget_Drop(ByVal pDataObj As olelib.IDataObject, ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As olelib.DROPEFFECTS)
   ' Update the IDataObject property
   Set m_oDataObject.IDataObject = pDataObj
   
   RaiseEvent OleDragDrop(m_oDataObject, grfKeyState, ptX, ptY, pdwEffect)
End Sub
'
' WBCtrl
'
' Return the WebBrowser control instance
'
Public Property Get WBCtrl() As SHDocVw.WebBrowser
Attribute WBCtrl.VB_UserMemId = 0
   Set WBCtrl = m_oWebBrowser
End Property
Private Sub vFrmWeb_Activate()
ActiveMe 1
End Sub
'Private Sub vFrmWeb_Deactivate()
'ActiveMe 0
'
'End Sub
'
Private Sub vFrmWeb_GotFocus()
ActiveMe 1
End Sub
'
'Private Sub vFrmWeb_LostFocus()
'ActiveMe 0
'End Sub
Public Sub ActiveMe(fActive As bool)
Dim oOO As olelib.IOleInPlaceActiveObject
   Set oOO = m_oWebBrowser
   ' Notify the control that the window was activated
   oOO.OnFrameWindowActivate fActive
   
End Sub
Private Sub vFrmWeb_Resize()
Call ResizeWeb
End Sub
Public Sub ResizeWeb()
Dim oOO As IOleInPlaceObject
Dim tRect As olelib.RECT
   ' Get the IOleInPlaceObject interface
   Set oOO = m_oWebBrowser
   
   ' Resize the control
   tRect.Right = vFrmWeb.ScaleWidth
   tRect.Bottom = vFrmWeb.ScaleHeight
   oOO.SetObjectRects tRect, tRect
End Sub
Public Sub INIAll(nfrm As Form)
nfrm.ScaleMode = vbPixels
Set vFrmWeb = nfrm
Call pvCreateWBControl
Call ResizeWeb
End Sub
Private Sub IniVars()
Created = False
' Initialize global variables
If CF_URL = 0 Then mWebbrowser.Initialize
' Initialize properties
m_lDownloadCtrl = DLCTL_Default
m_bBrowseMode = True
' Create the Zone Manager object
CoInternetCreateZoneManager Nothing, m_oZM, 0
SecurityZone = Internet
HostInfo = hfDefault
m_sUserAgent = ""
End Sub
Public Sub Release()
Dim oOleObj As IOleObject
Dim tMSG As olelib.MSG
Dim tRect As olelib.RECT
   
   ' Get the IOleObject interface
   Set oOleObj = m_oWebBrowser
   
   
   ' Activate the document
   oOleObj.DoVerb OLEIVERB_INPLACEACTIVATE, tMSG, Me, 0, vFrmWeb.hWnd, tRect
End Sub

						