一直没有找到自定义浏览器的方法,经老马推荐,找到了L-E浏览器的源码,啃了一星期,终于提取出了一份可用的代码.源码改自L-E浏览器.感谢作者.实现原理参考了COM原理与应用.另外关于代码中的OnAmbientPropertyChange -5512相信很多人会有疑问.请参照此帖[http://topic.csdn.net/u/20101117/17/b465d207-cb59-4111-bcda-5bdf3ca7f710.html].感谢hpygzhx520.
源码下载:http://lib.ldong.net/webbrowser.rar
需要有olelb.tbl(必需)和olelib2.tbl(可选)
以下是cWebbrowser的代码
Option Explicit
Implements olelib.IOleClientSite
Implements olelib2.IOleInPlaceSite
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long,ByVal hWndNewParent As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long,ByVal nIndex As Long,ByVal dwNewLong As Long) As Long
'Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long,lpRect As RECT) As Long
Private Const GWL_USERDATA = (-21)
Private m_oWebBrowser As SHDocVw.Webbrowser ' WebBrowser control
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
'Internet Explorer 6 or later.
'Specifies that the hosted browser should use themes for pages it displays.
'hfTheme= DOCHOSTUIFLAG_THEME = 0x00040000
hfTheme = &H40000
hfDefault = hfEnableFormAutocomplete Or hfEnableIME Or hfTheme
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
'ÏÂÔØ¿ØÖƱ¾µØ±äÁ¿
Private mDownloadCtrl As Long 'DownloadCtrlFlags
Private mDL_Image As Boolean
Private mDL_BgSound As Boolean
Private mDL_Video As Boolean
Private mDL_Script As Boolean
Private mDL_ActiveX As Boolean
Private mDL_JavaApplet As Boolean
Private mDl_DlActiveX As Boolean
Private vFrmWeb As Object
Private Created As Boolean
'Webbrowser Hwnd
Private m_hOleWindow&
'
' 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 DownloadCtrlEX() As DownloadCtrlFlags
DownloadCtrlEX = mDownloadCtrl
End Property
Public Property Let DownloadCtrlEX(ByVal NewFlags As DownloadCtrlFlags)
Dim oOC As olelib.IOleControl
mDownloadCtrl = 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
'
Private Sub pvCreateWBControl(objWeb As SHDocVw.Webbrowser)
Dim oOleObj As olelib.IOleObject
Dim oUnk As olelib.IUnknown
'Dim oFrame As IOleInPlaceFrame
Dim oOC As olelib.IOleControl
'Dim tMSG As olelib.MSG
Dim tRect As olelib.RECT
Dim tOle As olelib.IOleWindow
' Create the WebBrowser control
'CoCreateInstance CLSID_WebBrowser,Nothing,CLSCTX_INPROC_SERVER,IID_IUnknown,oUnk
' Get the WebBrowser interface
Set m_oWebBrowser = objWeb ' oUnk
'Set oUnk = Nothing
' Get the IOleObject interface
Set oOleObj = m_oWebBrowser
' Set the client site
oOleObj.SetClientSite Me
Set tOle = m_oWebBrowser
m_hOleWindow = tOle.GetWindow()
' Call GetClientRect(m_hOleWindow,tRect)
' Debug.Print tRect.Left,tRect.Right
' Activate the document
'Debug.Print vFrmWeb.hwnd,frmBrowser.Picture1.hwnd,frmBrowser.hwnd,vFrmWeb.Picture1.hwnd
' SetParent m_hOleWindow,vFrmWeb.Picture1.hwnd
oOleObj.DoVerb OLEIVERB_INPLACEACTIVATE,Me,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
'save webbrowser obj ptr into the 32-bit value associated with the window
SetWindowLong m_hOleWindow,GWL_USERDATA,ObjPtr(m_oWebBrowser)
Set oOleObj = Nothing
Set oUnk = Nothing
Set oOC = Nothing
End Sub
Public Property Get hWnd() As Long
hWnd = m_hOleWindow
End Property
'---------------------------------------------------------------------------------------
' Procedure : pvUnloadWBControl
' DateTime : 2006-10-19 20:31
' Author : lingll
' email : lingll_xl@163.com
' Purpose : release the reference of WBControl and unload it
'---------------------------------------------------------------------------------------
Public Function pvReleaseWBControl() As Boolean
Dim oOleObj As olelib.IOleObject
If Created Then
Set oOleObj = m_oWebBrowser
Set m_oWebBrowser = Nothing
'oOleObj.SetClientSite Nothing
oOleObj.Close OLECLOSE_NOSAVE
oOleObj.SetClientSite Nothing
Set oOleObj = Nothing
End If
Set vFrmWeb = Nothing
End Function
Private Sub Class_Initialize()
Call IniVars
IniDownloadControl
End Sub
Private Function IOleClientSite_GetContainer() As olelib.IOleContainer
' Err.Raise E_NOTIMPL
Set IOleClientSite_GetContainer = vFrmWeb
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 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
'if use "Set ppFrame = vFrmWeb",the webbrowser will get hold up
'all keyboard event,then we can find we cant use left or right key
'on address bar
'if no use "Set ppFrame = vFrmWeb",we should send keys to
'webbrowser manually,in mGetMessage.GetMsgProc
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()
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
Public Sub ResizeWeb(X&,Y&,cx&,cy&,Optional useDefault As Boolean = False)
Dim oOO As IOleInPlaceObject
Dim tRect As olelib.RECT
' Get the IOleInPlaceObject interface
Set oOO = m_oWebBrowser
' Resize the control
If useDefault Then
tRect.Right = vFrmWeb.ScaleWidth
tRect.Bottom = vFrmWeb.ScaleHeight
Else
tRect.Left = X
tRect.Top = Y
tRect.Right = X + cx
tRect.Bottom = Y + cy
End If
'SetParent m_hOleWindow,vFrmWeb.hwnd
oOO.SetObjectRects tRect,tRect
End Sub
Public Sub INIAll(nfrm As Object,objWeb As SHDocVw.Webbrowser)
'nfrm.ScaleMode = vbPixels
Set vFrmWeb = nfrm
Debug.Print nfrm.Name
'If Not m_NewWinMan Is Nothing Then
'm_NewWinMan.InitObj vFrmWeb
'End If
Call pvCreateWBControl(objWeb)
' Call ResizeWeb(0,True)
End Sub
Public Property Get Webbrowser() As SHDocVw.Webbrowser
'frmBrowser.ScaleMode = vbPixels
'Set vFrmWeb = objWB.Parent
'Debug.Print vFrmWeb.Name
' Call pvCreateWBControl(objWB)
'Call ResizeWeb(objWB.Left,objWB.Top,objWB.Width,objWB.Height,False)
Set Webbrowser = m_oWebBrowser
End Property
Private Sub IniVars()
Created = False
' Initialize properties
mDownloadCtrl = DLCTL_Default
mDL_BgSound = False ' True
mDL_Image = False ' gDL_Image 'True
mDL_Script = True 'True
mDL_Video = False 'True
mDL_ActiveX = True ' True
mDL_JavaApplet = False 'True
mDl_DlActiveX = True
End Sub
'³õʼ»¯ÏÂÔØ¿ØÖÆ,»ñµÃmDownloadControl
Private Sub IniDownloadControl()
mDownloadCtrl = DLCTL_Default 'Or DLCTL_NO_DLACTIVEXCTLS 'Or DLCTL_SILENT
If mDl_DlActiveX Then
Else
mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_DLACTIVEXCTLS
End If
If mDL_Image Then
Else
mDownloadCtrl = mDownloadCtrl Xor DLCTL_DLIMAGES
End If
If mDL_BgSound Then
Else
mDownloadCtrl = mDownloadCtrl Xor DLCTL_BGSOUNDS
End If
If mDL_Video Then
Else
mDownloadCtrl = mDownloadCtrl Xor DLCTL_VIDEOS
End If
If Not mDL_Script Then
mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_SCRIPTS
Else
End If
'====== ¸ÄÓÉ vCWebMe_ProcessAction ¿ØÖÆ =======
If Not mDL_ActiveX Then
mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_RUNACTIVEXCTLS
Else
End If
'===============================================
If Not mDL_JavaApplet Then
mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_JAVA
Else
End If
Debug.Print mDownloadCtrl
End Sub
'==================================================
'======== ÏÂÔØ¿ØÖÆ,ÔÊÐíÏÂÔصÄÊôÐÔ,ÈçͼƬ ===========
'ͼƬ
Public Property Get DL_Image() As Boolean
DL_Image = mDL_Image
End Property
Public Property Let DL_Image(ByVal vNewValue As Boolean)
mDL_Image = vNewValue
Call IniDownloadControl
DownloadCtrlEX = mDownloadCtrl
m_oWebBrowser.Refresh2 1
End Property
'±³¾°ÒôÀÖ
Public Property Get DL_BgSound() As Boolean
DL_BgSound = mDL_BgSound
End Property
Public Property Let DL_BgSound(ByVal vNewValue As Boolean)
mDL_BgSound = vNewValue
Call IniDownloadControl
DownloadCtrlEX = mDownloadCtrl
m_oWebBrowser.Refresh2 1
End Property
'ÊÓƵ
Public Property Get DL_Video() As Boolean
DL_Video = mDL_Video
End Property
Public Property Let DL_Video(ByVal vNewValue As Boolean)
mDL_Video = vNewValue
Call IniDownloadControl
DownloadCtrlEX = mDownloadCtrl
m_oWebBrowser.Refresh2 1
End Property
'½Å±¾
Public Property Get DL_Script() As Boolean
DL_Script = mDL_Script
End Property
Public Property Let DL_Script(ByVal vNewValue As Boolean)
mDL_Script = vNewValue
Call IniDownloadControl
DownloadCtrlEX = mDownloadCtrl
m_oWebBrowser.Refresh2 1
End Property
'ÔËÐÐActiveX Control
Public Property Get DL_ActiveX() As Boolean
DL_ActiveX = mDL_ActiveX
End Property
Public Property Let DL_ActiveX(ByVal vNewValue As Boolean)
mDL_ActiveX = vNewValue
Call IniDownloadControl
DownloadCtrlEX = mDownloadCtrl
m_oWebBrowser.Refresh2 1
End Property
'ÔËÐÐJava Applet
Public Property Get DL_JavaApplet() As Boolean
DL_JavaApplet = mDL_JavaApplet
End Property
Public Property Let DL_JavaApplet(ByVal vNewValue As Boolean)
mDL_JavaApplet = vNewValue
Call IniDownloadControl
DownloadCtrlEX = mDownloadCtrl
m_oWebBrowser.Refresh2 1
End Property
'ÏÂÔØActiveX
Public Property Get Dl_DlActiveX() As Boolean
Dl_DlActiveX = mDl_DlActiveX
End Property
Public Property Let Dl_DlActiveX(ByVal vNewValue As Boolean)
mDl_DlActiveX = vNewValue
Call IniDownloadControl
DownloadCtrlEX = mDownloadCtrl
m_oWebBrowser.Refresh2 1
End Property
'ͳһÉèÖÃ
Public Sub Dl_EnableAll(nAll As Boolean)
mDL_BgSound = nAll
mDL_Image = nAll
mDL_Script = nAll
mDL_Video = nAll
mDL_ActiveX = nAll
mDL_JavaApplet = nAll
mDl_DlActiveX = nAll
Call IniDownloadControl
DownloadCtrlEX = mDownloadCtrl
m_oWebBrowser.Refresh2 1
End Sub
'ÅúÁ¿ÉèÖÃ
Public Sub Dl_BatchSet(Optional blnImage As Boolean = True,_
Optional blnScript As Boolean = True,Optional blnBgSound As Boolean = True,_
Optional blnVideo As Boolean = True,Optional blnActiveX As Boolean = True,_
Optional blnJavaApplet As Boolean = True,Optional blnDlActiveX As Boolean = True)
mDL_BgSound = blnBgSound
mDL_Image = blnImage
mDL_Script = blnScript
mDL_Video = blnVideo
mDL_ActiveX = blnActiveX
mDL_JavaApplet = blnJavaApplet
mDl_DlActiveX = blnDlActiveX
Call IniDownloadControl
DownloadCtrlEX = mDownloadCtrl
m_oWebBrowser.Refresh2 1
End Sub
调用方法:在VB工程中添加此类,拉一个Webbrowser控件,用cWebbrowser的IniAll方法初始化一下,然后就可以自由控制了.
Iniall方法的第一个参数是Webbrowser的容器,用于给Webbrowser定位的.第二个参数就是Webbrowser控件了.
olelib2.IOleInPlaceSite是用来定位浏览器的,可以不引用.
原文链接：https://www.f2er.com/vb/261608.html