感动的事开头怎么写:我的浏览器-浏览器接口

原文::http://chaolihf.spaces.live.com/Blog/cns!86CFF65E5D2AB570!156.entry

我的浏览器-浏览器接口(4)

为了扩展浏览器的功能，往往需要实现以下的接口，这些接口的定义可以参考MSDN，TLB文件可以从http://www.mvps.org/emorcillo/en/index.shtml里面下载，这个网址也是开发我的浏览器很重要的一个参考网站。LExtendDefine是自己写的扩展，首先写一个ODL，然后用VC带的MKTYPLIB.EXE程序编译生成TLB文件即可。ISubClass是www.vbaccelerator.com中大多数控件都使用的一个实现子类的一个接口，这个网站给出了很多实现控件的方法，我的浏览器重写了几乎所有的Windows标准控件，都是基于ISubClass，但对此进行了修改已方便操作。说一句题外话为什么要重写这个控件呢，为什么不使用Window Common Dialog里面提供的控件呢，原因有二： 一是这些控件的方法不全，难以符合XP等新系统界面和功能方面的要求，而且控件也相对较少；二是这些控件会使VB应用程序无法释放内存。如果你在窗口中放入这些控件，正常情况下最小化窗口时进程会释放掉一部分运行时内存，但加入后就不能释放，这个算是VB的一个Bug。Implements IOleClientSite       '将WbBrowser中的Document窗口作为当前Form的客户端，并使其通过此接口通知当前Form
Implements olelib2.IOleInPlaceSite '容器接口
Implements olelib.IDocHostUIHandler 'Document文档中的界面接口，处理与用户交互方面的问题
Implements olelib.IDocHostShowUI    '实现对Help和MessageBox的接口
Implements olelib2.IServiceProvider '实现服务提供接口
Implements olelib.IInternetSecurityManager
Implements olelib2.IOleCommandTarget
Implements IOleWindow
Implements IInputObjectSite
Implements LExtendDefine.IDownloadManager
Implements LExtendDefine.INewWindowManager
Implements ISubclass下面是关联接口的代码Private Sub ImplementSite()
    Dim tMSG As olelib.MSG
    Dim tRECT As olelib.RECT
    Dim objOleObject As IOleObject
    Dim objOleControl As IOleControl
    Dim objOleWindow As IOleWindow
    On Error GoTo ErrProc
    m_strBrowserAgent = cBI.BrowserTag
    olelib.CLSIDFromString IID_IWebBrowser2, udtIWebBrowser2UUID
    olelib.CLSIDFromString IID_IUnknown, udtIUnknown
    CoInternetCreateZoneManager Nothing, m_objOZM, 0
    Me.ScaleMode = vbPixels
    Set objOleObject = Me.wbBrowser.Object
    Set objOleWindow = objOleObject.GetClientSite
    objOleObject.DoVerb OLEIVERB_HIDE, tMSG, objOleWindow, 0, 0, tRECT
    m_lngDocumentHwnd = GetWindow(objOleWindow.GetWindow, GW_CHILD)
    m_OleWindow = m_lngDocumentHwnd
    SetParent m_lngDocumentHwnd, Me.hwnd
    objOleObject.SetClientSite Me
    objOleObject.DoVerb OLEIVERB_INPLACEACTIVATE, tMSG, Me, 0, Me.hwnd, tRECT
    p_GlobalLF.SetFocusWindow m_lngDocumentHwnd
    Set objOleControl = objOleObject
    If m_strBrowserAgent <> "" Then
        objOleControl.OnAmbientPropertyChange DISPID_AMBIENT_USERAGENT
    End If
    objOleControl.OnAmbientPropertyChange DISPID_AMBIENT_DLCONTROL
    Exit Sub
ErrProc:
    Debug.Print "Err:ImplementSite:" & Err.Description
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
    '此接口只可以实现对window.alert方法进行控制，对prompt毫无用处
    If bolIsInRecycle Then
        IDocHostShowUI_ShowMessage = S_FALSE
    Else
        If Timer - m_PreDisableActiveXTime < 1 Then
            m_PreDisableActiveXTime = m_PreDisableActiveXTime - 2
            IDocHostShowUI_ShowMessage = S_FALSE
        Else
            If GetAsyncKeyState(vbKeyControl) <> 0 Or bolClosing Then
                If Not bolClosing Then
                    If Index = GetActiveBrowser Then
                        Call StatusChange(LoadResourceString(STRING_RESOURCE_58) & olelib.SysAllocString(lpszText))
                    End If
                End If
                IDocHostShowUI_ShowMessage = S_FALSE
            Else
                Err.Raise E_NOTIMPL
            End If
        End If
    End If
End FunctionPrivate Sub IDocHostUIHandler_EnableModeless(ByVal fEnable As olelib.BOOL)
    'ms-help://MS.MSDNQTR.2003APR.1033/DHTML/workshop/samples/author/dhtml/refs/showModalDialog.htm
    If fEnable And m_bolOpenMenu Then
        m_PreOperateTime = Timer
        m_bolOpenMenu = False
        If cBI.ContentFilter Then
            mdiMainView.InstallFilter False, False
        End If
    End If
    Err.Raise E_NOTIMPL
End SubPrivate Function IDocHostUIHandler_FilterDataObject(ByVal pDO As olelib.IDataObject) As olelib.IDataObject
    Err.Raise E_NOTIMPL
End FunctionPrivate Function IDocHostUIHandler_GetDropTarget(ByVal pDropTarget As olelib.IDropTarget) As olelib.IDropTarget
'这里给出一个非常奇怪的例子，如果去除以下代码的第二行就可以拖放A，否则不可以，原网址为第二行
'
'
'
'目录
    If cBI.bolAllowDrag Then
        If cDropTarget Is Nothing Then
            Set cDropTarget = New LDropTarget
        End If
        Set IDocHostUIHandler_GetDropTarget = cDropTarget
    Else
        Err.Raise E_NOTIMPL
    End If
End FunctionPrivate Function IDocHostUIHandler_GetExternal() As Object
    If cBI.objExternalObject Is Nothing Then
        Set cBI.objExternalObject = New cExternalObject
    End If
    Set IDocHostUIHandler_GetExternal = cBI.objExternalObject
End FunctionPrivate Sub IDocHostUIHandler_GetHostInfo(pInfo As olelib.DOCHOSTUIINFO)
    With pInfo
        .cbSize = LenB(pInfo)
        .dwFlags = m_lngHostInfo
    End With
End SubPrivate Sub IDocHostUIHandler_ShowContextMenu(ByVal dwContext As olelib.ContextMenuTarget, pPOINT As olelib.Point, ByVal pCommandTarget As olelib.IOleCommandTarget, ByVal HTMLTagElement As Object)
    Dim udtGGUID As UUID
    Dim lngSelection As Long
    Dim lngModuleHandle As Long
    Dim lngHwnd As Long
    Dim hMenu As Long
    Dim objOleWindow As IOleWindow
    Dim udtMenuItemInfo As MENUITEMINFO
    'm_bolShowCustomMenu = False
    If m_bolShowCustomMenu Then
        m_bolShowCustomMenu = False
    Else
        m_bolOpenMenu = True
'        用在自定义菜单
'        olelib.CLSIDFromString CGID_ShellDocView, udtGGUID
'        Set objOleWindow = pCommandTarget
'        lngHwnd = objOleWindow.GetWindow()
'        lngModuleHandle = LoadLibrary("SHDOCLC.DLL")
'        If (lngModuleHandle <> 0) Then
'            hMenu = LoadMenu(lngModuleHandle, MakeLong(IDR_BROWSE_CONTEXT_MENU, 0))
'            hMenu = GetSubMenu(hMenu, dwContext)
'            udtMenuItemInfo.cbSize = Len(udtMenuItemInfo)
'            udtMenuItemInfo.fMask = MIIM_SUBMENU
'            udtMenuItemInfo.hSubMenu = GetMimecSetMenu(pCommandTarget, udtGGUID)
'            Call SetMenuItemInfo(hMenu, IDM_LANGUAGE, False, udtMenuItemInfo)
'            Call GetRegisterMenu(pCommandTarget, udtGGUID, hMenu, dwContext)
'            'Call DeleteMenu(hMenu, IDM_VIEWSOURCE, MF_BYCOMMAND )
'            lngSelection = TrackPopupMenu(hMenu, TPM_LEFTALIGN Or TPM_RIGHTBUTTON Or TPM_RETURNCMD, pPOINT.x, pPOINT.y, 0, lngHwnd, 0)
'            Call SendMessageAPI(lngHwnd, WM_COMMAND, lngSelection, ByVal 0)
'            Call FreeLibrary(lngModuleHandle)
'            Exit Sub
'        End If
        Err.Raise E_NOTIMPL
    End If
End SubPrivate Sub IDocHostUIHandler_TranslateAccelerator(lpMsg As olelib.MSG, pguidCmdGroup As olelib.UUID, ByVal nCmdID As Long)
    Dim bolTranslate As Boolean
    bolTranslate = Not CBool(IsChild(m_lngDocumentHwnd, lpMsg.hwnd)) '检查窗口是不是IE的窗口，如果不是则需要转发
    If bolTranslate Then '在消息不是有当前浏览器接收时应将其转发
        bolTranslate = False
        Select Case lpMsg.wParam
            Case vbKeyLeft, vbKeyRight, vbKeyDown, vbKeyUp, vbKeyBack, vbKeyDelete, vbKeyInsert, vbKeyHome, vbKeyEnd, vbKeyPageDown, vbKeyPageUp, vbKeyEscape, vbKeyReturn, vbKeyTab:
                bolTranslate = True
            Case vbKeyC, vbKeyX, vbKeyV, vbKeyZ, vbKeyA:
                If GetAsyncKeyState(vbKeyControl) <> 0 Then
'                    If CBool(IsChild(mdiMainView.PicSideBar.hwnd, lpMsg.hwnd)) Then
'                        Select Case lpMsg.wParam
'                            Case vbKeyC:
'                                SendMessageAPI lpMsg.hwnd, &H301, 0, 0
'                            Case vbKeyV:
'                                SendMessageAPI lpMsg.hwnd, &H302, 0, 0
'                        End Select
'                    End If
                    bolTranslate = True
                End If
        End Select
        If bolTranslate Then
            Call TranslateMessage(lpMsg)
            Call DispatchMessage(lpMsg)
            lpMsg.wParam = 0
        End If
    End If
    'If Not bolTranslate And lpMsg.message = WM_KEYDOWN And lpMsg.wParam = vbKeyReturn Then
        m_PreOperateTime = Timer
    'End If
    Err.Raise E_NOTIMPL
End SubPrivate Sub IDownloadManager_Download(ByVal pmk As LExtendDefine.IMoniker, ByVal pbc As LExtendDefine.IBindCtx, ByVal dwBindVerb As Long, ByVal grfBINDF As Long, pbindinfo As LExtendDefine.BINDINFO, ByVal pszHeaders As Long, ByVal pszRedir As Long, ByVal uiCP As Long)
    Dim lngURL As Long
    Dim strUrl As String
    Dim frmDL As frmDownload
    Dim lngSize As Long
    Dim arrData() As Byte
    Dim bolClose As Boolean
    If Not cBI.CustomDownload Then
        Err.Raise E_NOTIMPL
    Else
        lngURL = pmk.GetDisplayName(pbc, Nothing)
        If lngURL = 0 Then
            Err.Raise E_NOTIMPL
        Else
            strUrl = olelib.SysAllocString(lngURL)
            If LenB(wbBrowser.LocationURL) = 0 Then bolClose = True
            Call UpdateHistoryURL(strUrl)
            Set frmDL = New frmDownload
            With frmDL
                .URL = strUrl
                olelib.SysFreeString strUrl
                If pszHeaders <> 0 Then
                    .Header = olelib.SysAllocString(pszHeaders)
                End If
                If InStr(1, .Header, "Referer") = 0 Then
                    .Referer = wbBrowser.LocationURL
                End If
                If VarPtr(pbindinfo) <> 0 Then
                    Select Case pbindinfo.dwBindVerb
                        Case BINDVERB_GET:
                            .HttpMethod = HTTPGET
                        Case BINDVERB_POST:
                            .HttpMethod = HTTPPOST
                    End Select
                    If pbindinfo.stgmedData.Data <> 0 Then
                       If pbindinfo.stgmedData.TYMED = TYMED_HGLOBAL Then
                            lngSize = GlobalSize(pbindinfo.stgmedData.Data)
                            If lngSize > 0 Then
                                ReDim arrData(lngSize - 1)
                                CopyMemory arrData(0), ByVal pbindinfo.stgmedData.Data, lngSize
                                .PostData = StrConv(arrData, vbUnicode)
                            End If
                        End If
                    End If
                End If
                .Show
                Do While .DownloadAction = DownloadNotReady
                    DoEvents: DoEvents: DoEvents
                Loop
                If bolClose Then
                    CloseWebView Index, False
                End If
                If .DownloadAction = DownloadUseDefault Then
                    Err.Raise E_NOTIMPL
                End If
            End With
        End If
    End If
End SubPrivate Sub IInternetSecurityManager_ProcessUrlAction(ByVal pwszUrl As Long, ByVal dwAction As olelib.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 lngIndex As Long
    Dim bolDisableControl As Boolean
    Dim strCLSID As String
    If m_CurrentType = LNoneType And Not m_AllowRunActivwX Then
        If cbContext > 0 Then
            If cBI.bolAllowDisableControls Then
                If dwAction >= URLACTION_ACTIVEX_MIN And dwAction <= URLACTION_ACTIVEX_MAX Then
                    strCLSID = p_GlobalLF.ConvertGUIDToString(VarPtr(pContext))
                    lngIndex = cBI.DisableControls.findItem(LCase(strCLSID))
                    If lngIndex = -1 Then
                        bolDisableControl = cBI.bolFilterAllControls
                    Else
                        bolDisableControl = cBI.DisableControls.key(lngIndex)
                    End If
                    If bolDisableControl Then
                        StatusChange LoadResourceString(STRING_RESOURCE_16) & strCLSID
                        Call cBI.AddBlockControl(olelib.SysAllocString(pwszUrl), strCLSID)
                        MoveMemory ByVal pPolicy, URLPOLICY_DISALLOW, 4&
                        m_PreDisableActiveXTime = Timer
                        Exit Sub
                    End If
                End If
            End If
        End If
        Err.Raise INET_E_DEFAULT_ACTION
    Else
        MoveMemory ByVal pPolicy, URLPOLICY_ALLOW&, 4&
    End If
End SubPrivate Sub INewWindowManager_EvaluateNewWindow(ByVal pszURL As Long, ByVal pszName As Long, ByVal pszUrlContext As Long, ByVal pszFeatures As Long, ByVal fReplace As Boolean, ByVal dwFlags As Long, ByVal dwUserActionTime As Long)
    If (dwFlags And NWMF_HTMLDIALOG) Or (dwFlags And NWMF_SHOWHELP) Then
        If cBI.lngFilterDialogMethod = LFilterDialogSP2 Then
            StatusChange LoadResourceString(STRING_RESOURCE_36) & p_GlobalLF.StringFromPointer(pszURL, True)
            Err.Raise S_FALSE
        End If
    End If
End SubPrivate Sub IOleCommandTarget_Exec(pguidCmdGroup As olelib.UUID, ByVal nCmdID As Long, ByVal nCmdexecopt As olelib.OLECMDEXECOPT, pvaIn As Variant, pvaOut As Variant)
    Dim objCommandTarget As IOleCommandTarget
    Dim objDocument As HTMLDocument
    Dim objEvent As IHTMLEventObj
    Select Case nCmdID
        Case OLECMDID_SHOWSCRIPTERROR    '省略了部分判断代码，可能会出现错误，参见HOWTO: Handle Script Errors as a WebBrowser Control Host
            If Not cBI.DisableScriptDialog And Not bolIsInRecycle Then
                Err.Raise OLECMDERR_E_NOTSUPPORTED
            Else
                pvaOut = True
                Set objDocument = pvaIn
                Set objEvent = GetScriptError(objDocument)
                If Not objEvent Is Nothing Then
                    With objEvent
                        Call StatusChange(LoadResourceString(STRING_RESOURCE_17) & ":" & .ErrorMessage _
                        & " " & LoadResourceString(STRING_RESOURCE_27) & "=" & .ErrorLine _
                        & " " & LoadResourceString(STRING_RESOURCE_28) & "=" & .ErrorCharacter _
                        & " " & LoadResourceString(STRING_RESOURCE_29) & "=" & .ErrorCode & " URL=" & .errorUrl)
                        cBI.AddScriptError .errorUrl, .ErrorMessage, .ErrorLine, .ErrorCharacter, .ErrorCode
                    End With
                End If
            End If
        Case OLECMDID_PREREFRESH: ', REFRESHBYCMD, REFRESHBYCONTEXTMENU, REFRESHBYF5:
            Call wbBrowser_Refresh
            Err.Raise OLECMDERR_E_UNKNOWNGROUP
        Case OLECMDID_SETPROGRESSMAX:
            Call wbBrowser_SetProgressMax
            Err.Raise OLECMDERR_E_UNKNOWNGROUP
        Case Else
            'Set objCommandTarget = wbBrowser
            'Call objCommandTarget.Exec(pguidCmdGroup, nCmdID, nCmdexecopt, pvaIn, pvaOut)
            Err.Raise OLECMDERR_E_UNKNOWNGROUP
    End Select
End SubPrivate Function IOleInPlaceSite_GetWindow() As Long
    IOleInPlaceSite_GetWindow = Me.hwnd
End FunctionPrivate 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 = Me
    Set ppDoc = Me
End SubPrivate Sub IOleInPlaceSite_OnInPlaceActivate()
    '当此Form活动时激活其中的Document
    Dim objPlace As IOleInPlaceFrame
    Set objPlace = Me
    objPlace.SetActiveObject wbBrowser.Document, 0
End Sub
Private Function IOleWindow_GetWindow() As Long
    IOleWindow_GetWindow = m_OleWindow
End FunctionPrivate Sub IServiceProvider_QueryService(guidService As olelib.UUID, riid As olelib.UUID, ppvObject As Long)
    Dim objUnknown As olelib.IUnknown
    Dim lngResult As Long
    Select Case UCase$(p_GlobalLF.ConvertGUIDToString(VarPtr(guidService)))
        Case IID_IDownloadManager:
            Dim objIDM As IDownloadManager
            Set objUnknown = Me
            objUnknown.AddRef
            Set objIDM = Me
            MoveMemory ppvObject, objIDM, 4&
        Case IID_INewWindowManager:
            If cBI.lngFilterDialogMethod <> LFilterDialogSP2 Then
                Err.Raise E_NOINTERFACE
            Else
                Dim objINWM As INewWindowManager
                Set objUnknown = Me
                objUnknown.AddRef
                Set objINWM = Me
                MoveMemory ppvObject, objINWM, 4&
            End If
        Case IID_IInternetSecurityManager:
            Dim objISM As IInternetSecurityManager
            Set objUnknown = Me
            objUnknown.AddRef
            Set objISM = Me
            MoveMemory ppvObject, objISM, 4&
        Case IID_IWebBrowserAPP:
            Dim objWB As IWebBrowserApp
            Set objWB = Me
            Set objUnknown = Me
            objUnknown.AddRef
            MoveMemory ppvObject, objWB, 4&
        Case Else:
            If Not cBI.AllowPlugins Then
                Err.Raise E_NOINTERFACE
            Else
                If olelib.IsEqualGUID(riid, udtIUnknown) Then
                    Err.Raise E_NOINTERFACE
                Else
                    Set objUnknown = wbBrowser
                    lngResult = objUnknown.QueryInterface(riid, ppvObject)
                    If lngResult <> 0 Then
                        ppvObject = 0
                        Err.Raise lngResult
                    End If
                End If
            End If
    End Select