VB6 HTMLForm

关于使用IE技术借助HTML来实现DirectUI的实验博主断断续续做了四年，期间就是因为这个实验烧坏了脑子才转行考了音乐的研究生。

这次成果是一个自认为调整得还算比较好用的VB6窗体类，用以显示HTML对话框。基本效果如图所示：

能看出这是嵌入了一个IE么？当然，可以做得更好看一些，前端网页能做多漂亮这里就可以有多漂亮。

为什么使用VB6。第一，VB窗体本身实现了作为OLE容器的功能，如果用原生C++，除了需要自己处理窗口消息外，还需要非常熟悉COM、OLE自动化等知识，很显然我不想再烧坏一次脑子然后再去考个什么专业的研。

第二，VB支持弱类型的IDispatch后期绑定，可以非常方便地直接在代码中与HTML互操作。例如HTMLForm公开了一个Object属性指向DOM中的window对象，那么完全可以写出如下代码：
frm.Object.Text1.innerText = “hello world”
frm.Object.Button1.style.display = “none”
另一方面，也可以直接通过Dim WithEvents As HTMLDocument来监听HTML上的事件，并通过window.event.srcElement.id来确定哪个按钮被点击等，编程灵活性完全不输于VB Form。

更多功能请读者自己探索。以下贴代码。

'Module: HTMLForm.frm r140520
'Author: gmsj0001(http:lxf.me)

Option Explicit

Implements olelib.IOleClientSite
Implements olelib2.IOleInPlaceSite
Implements olelib.IDocHostUIHandler

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Private WithEvents m_WebBrowser As SHDocVw.WebBrowser
Private m_ScriptSite As Object

Public Event DocumentComplete()

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
    Err.Raise E_NOTIMPL
End Function

Private Function IDocHostUIHandler_GetExternal() As Object
    Set IDocHostUIHandler_GetExternal = m_ScriptSite
End Function

Private Sub IDocHostUIHandler_GetHostInfo(pInfo As olelib.DOCHOSTUIINFO)
    pInfo.cbSize = LenB(pInfo)
    pInfo.dwFlags = DOCHOSTUIFLAG_DIALOG + DOCHOSTUIFLAG_NO3DBORDER + DOCHOSTUIFLAG_SCROLL_NO + &H40000 + &H200000
End Sub

Private Sub IDocHostUIHandler_GetOptionKeyPath(pOLESTRchKey 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 E_NOTIMPL
End Sub

Private Sub IDocHostUIHandler_OnFrameWindowActivate(ByVal fActivate As olelib.BOOL)
    Err.Raise E_NOTIMPL
End Sub

Private Sub IDocHostUIHandler_ResizeBorder(prcBorder As olelib.RECT, ByVal pUIWindow As olelib.IOleInPlaceUIWindow, ByVal fRameWindow As olelib.BOOL)
    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)
    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)
    Err.Raise E_NOTIMPL
End Sub

Private Function IDocHostUIHandler_TranslateUrl(ByVal dwTranslate As Long, ByVal pchURLIn As Long) As Long
    Err.Raise E_NOTIMPL
End Function

Private Sub IDocHostUIHandler_UpdateUI()
    Err.Raise E_NOTIMPL
End Sub

Private Function IOleClientSite_GetContainer() As olelib.IOleContainer
    Err.Raise E_NOINTERFACE
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)
End Sub

Private Sub IOleClientSite_RequestNewObjectLayout()
    Err.Raise E_NOTIMPL
End Sub

Private Sub IOleClientSite_SaveObject()
    Err.Raise E_NOTIMPL
End Sub

Private Sub IOleClientSite_ShowObject()
End Sub

Private Sub IOleInPlaceSite_CanInPlaceActivate()
End Sub

Private Sub IOleInPlaceSite_ContextSensitiveHelp(ByVal fEnterMode As olelib.BOOL)
End Sub

Private Sub IOleInPlaceSite_DeactivateAndUndo()
End Sub

Private Sub IOleInPlaceSite_DiscardUndoState()
End Sub

Private Function IOleInPlaceSite_GetWindow() As Long
    IOleInPlaceSite_GetWindow = Me.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)
    Err.Raise E_NOTIMPL
End Sub

Private Sub IOleInPlaceSite_OnInPlaceActivate()
End Sub

Private Sub 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)
End Sub

Private Sub IOleInPlaceSite_Scroll(ByVal scrollX As Long, ByVal scrollY As Long)
End Sub

Public Sub Navigate(ByVal URL As String)
    m_WebBrowser.Navigate2 URL
End Sub

Public Sub SetScriptSite(pDisp As Object)
    Set m_ScriptSite = pDisp
End Sub

Public Property Get Object()
    Set Object = m_WebBrowser.Document.parentWindow
End Property

Public Property Get Browser()
    Set Browser = m_WebBrowser
End Property

Private Sub Form_Initialize()
    Load Me
End Sub

Private Sub Form_Load()
    Set m_WebBrowser = New WebBrowser
    Dim pOleObject As olelib.IOleObject
    Dim pRect As olelib.RECT
    Set pOleObject = m_WebBrowser
    pOleObject.SetClientSite Me
    pOleObject.DoVerb OLEIVERB_INPLACEACTIVATE, 0, Me, 0, Me.hwnd, pRect
    m_WebBrowser.Silent = True
End Sub

Private Sub Form_Resize()
    Dim pInPlaceObject As olelib.IOleInPlaceObject
    Dim rcClient As RECT
    GetClientRect Me.hwnd, rcClient
    Set pInPlaceObject = m_WebBrowser
    pInPlaceObject.SetObjectRects rcClient, rcClient
End Sub

Private Sub m_WebBrowser_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    If URL = "" Then Exit Sub
    RaiseEvent DocumentComplete
End Sub

Private Sub m_WebBrowser_NewWindow2(ppDisp As Object, Cancel As Boolean)
    Dim pNewWindow As New HTMLForm
    Set ppDisp = pNewWindow.Browser
    pNewWindow.Show
End Sub