![]() |
#2
def00112016-04-18 11:07
|

''Form代码:
Option Explicit
Private MyDrag As clsDrag
Private Sub Command1_Click()
Dim w1 As String '''随便给点文字,做测试用
w1 = "<font>dfslhlsf</font><br>hsfsfifsefs<br>dkgldglsl"
Wb.Document.body.innerHTML = w1
End Sub
Private Sub Form_Load()
Wb.Navigate "about:blank"
End Sub
Private Sub Wb_DownloadComplete()
If MyDrag Is Nothing Then
Set MyDrag = New clsDrag
MyDrag.Init Wb.Document
End If
End Sub
''类clsDrag代码:
Option Explicit
Implements olelib.IDocHostUIHandler
Implements olelib.iDropTarget '''''这个接口怎么绑定?
Private mDOC As olelib.ICustomDoc
''Private oTest As clsDim
Private WithEvents clsDoc As HTMLDocument
Public Sub Init(ByVal bDoc As HTMLDocument)
Set mDOC = bDoc
mDOC.SetUIHandler Me ''绑定IDocHostUIHandler接口
Set clsDoc = bDoc
End Sub
Private Function clsDoc_ondragstart() As Boolean
clsDoc_ondragstart = True
''ie8只有这一个事件。没有:ondragend,ondragover等事件
End Function
Private Sub IDocHostUIHandler_EnableModeless(ByVal fEnable As olelib.BOOL)
' IDocHostUIHandler.EnableModeless fEnable
' Err.Raise E_NOTIMPL
End Sub
Private Function IDocHostUIHandler_FilterDataObject(ByVal pDO As olelib.IDataObject) As olelib.IDataObject
' Set IDocHostUIHandler_FilterDataObject = IDocHostUIHandler.FilterDataObject(pDO)
' Err.Raise E_NOTIMPL
End Function
Private Function IDocHostUIHandler_GetDropTarget(ByVal pDropTarget As olelib.iDropTarget) As olelib.iDropTarget
' Set IDocHostUIHandler_GetDropTarget = IDocHostUIHandler.GetDropTarget(pDropTarget)
'''在这里加断点没有任何反应啊!
Form1.Caption = "GetDropTarget>>" & Timer
End Function
Private Function IDocHostUIHandler_GetExternal() As Object
''Set oTest = New clsDim ''测试成功
''Set IDocHostUIHandler_GetExternal = oTest
End Function
Private Sub IDocHostUIHandler_GetHostInfo(pInfo As olelib.DOCHOSTUIINFO)
' IDocHostUIHandler.GetHostInfo pInfo
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_GetOptionKeyPath(pOLESTRchKey As Long, ByVal dw As Long)
' IDocHostUIHandler.GetOptionKeyPath pOLESTRchKey, dw
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_HideUI()
' IDocHostUIHandler.HideUI
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_OnDocWindowActivate(ByVal fActivate As olelib.BOOL)
' IDocHostUIHandler.OnDocWindowActivate fActivate
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_OnFrameWindowActivate(ByVal fActivate As olelib.BOOL)
' IDocHostUIHandler.OnFrameWindowActivate fActivate
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_ResizeBorder(prcBorder As olelib.RECT, ByVal pUIWindow As , ByVal fRameWindow As olelib.BOOL)
' IDocHostUIHandler.ResizeBorder prcBorder, pUIWindow, fRameWindow
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_ShowContextMenu(ByVal dwContext As olelib.ContextMenuTarget, pPOINT As olelib.POINT, ByVal pCommandTarget As , ByVal HTMLTagElement As Object)
' IDocHostUIHandler.ShowContextMenu dwContext, pPOINT, pCommandTarget, HTMLTagElement
' Err.Raise E_NOTIMPL
''禁止右键菜单===>成功!
End Sub
Private Sub IDocHostUIHandler_ShowUI(ByVal dwID As Long, ByVal pActiveObject As , ByVal pCommandTarget As , ByVal pFrame As , ByVal pDoc As )
' IDocHostUIHandler.ShowUI dwID, pActiveObject, pCommandTarget, pFrame, pDoc
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_TranslateAccelerator(lpMsg As olelib.MSG, pguidCmdGroup As olelib.UUID, ByVal nCmdID As Long)
' IDocHostUIHandler.TranslateAccelerator lpMsg, pguidCmdGroup, nCmdID
' Err.Raise E_NOTIMPL
End Sub
Private Function IDocHostUIHandler_TranslateUrl(ByVal dwTranslate As Long, ByVal pchURLIn As Long) As Long
' IDocHostUIHandler_TranslateUrl = IDocHostUIHandler.TranslateUrl(dwTranslate, pchURLIn)
' Err.Raise E_NOTIMPL
End Function
Private Sub IDocHostUIHandler_UpdateUI()
' 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 ptY As Long, pdwEffect As olelib.DROPEFFECTS)
Form1.Caption = "iDropTarget_DragEnter>>" & Timer
End Sub
Private Sub iDropTarget_DragLeave()
Form1.Caption = "iDropTarget_DragLeave>>" & Timer
End Sub
Private Sub iDropTarget_DragOver(ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As olelib.DROPEFFECTS)
Form1.Caption = "iDropTarget_DragOver>>" & Timer
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)
Form1.Caption = "iDropTarget_Drop>>" & Timer
End Sub
Option Explicit
Private MyDrag As clsDrag
Private Sub Command1_Click()
Dim w1 As String '''随便给点文字,做测试用
w1 = "<font>dfslhlsf</font><br>hsfsfifsefs<br>dkgldglsl"
Wb.Document.body.innerHTML = w1
End Sub
Private Sub Form_Load()
Wb.Navigate "about:blank"
End Sub
Private Sub Wb_DownloadComplete()
If MyDrag Is Nothing Then
Set MyDrag = New clsDrag
MyDrag.Init Wb.Document
End If
End Sub
''类clsDrag代码:
Option Explicit
Implements olelib.IDocHostUIHandler
Implements olelib.iDropTarget '''''这个接口怎么绑定?
Private mDOC As olelib.ICustomDoc
''Private oTest As clsDim
Private WithEvents clsDoc As HTMLDocument
Public Sub Init(ByVal bDoc As HTMLDocument)
Set mDOC = bDoc
mDOC.SetUIHandler Me ''绑定IDocHostUIHandler接口
Set clsDoc = bDoc
End Sub
Private Function clsDoc_ondragstart() As Boolean
clsDoc_ondragstart = True
''ie8只有这一个事件。没有:ondragend,ondragover等事件
End Function
Private Sub IDocHostUIHandler_EnableModeless(ByVal fEnable As olelib.BOOL)
' IDocHostUIHandler.EnableModeless fEnable
' Err.Raise E_NOTIMPL
End Sub
Private Function IDocHostUIHandler_FilterDataObject(ByVal pDO As olelib.IDataObject) As olelib.IDataObject
' Set IDocHostUIHandler_FilterDataObject = IDocHostUIHandler.FilterDataObject(pDO)
' Err.Raise E_NOTIMPL
End Function
Private Function IDocHostUIHandler_GetDropTarget(ByVal pDropTarget As olelib.iDropTarget) As olelib.iDropTarget
' Set IDocHostUIHandler_GetDropTarget = IDocHostUIHandler.GetDropTarget(pDropTarget)
'''在这里加断点没有任何反应啊!
Form1.Caption = "GetDropTarget>>" & Timer
End Function
Private Function IDocHostUIHandler_GetExternal() As Object
''Set oTest = New clsDim ''测试成功
''Set IDocHostUIHandler_GetExternal = oTest
End Function
Private Sub IDocHostUIHandler_GetHostInfo(pInfo As olelib.DOCHOSTUIINFO)
' IDocHostUIHandler.GetHostInfo pInfo
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_GetOptionKeyPath(pOLESTRchKey As Long, ByVal dw As Long)
' IDocHostUIHandler.GetOptionKeyPath pOLESTRchKey, dw
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_HideUI()
' IDocHostUIHandler.HideUI
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_OnDocWindowActivate(ByVal fActivate As olelib.BOOL)
' IDocHostUIHandler.OnDocWindowActivate fActivate
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_OnFrameWindowActivate(ByVal fActivate As olelib.BOOL)
' IDocHostUIHandler.OnFrameWindowActivate fActivate
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_ResizeBorder(prcBorder As olelib.RECT, ByVal pUIWindow As , ByVal fRameWindow As olelib.BOOL)
' IDocHostUIHandler.ResizeBorder prcBorder, pUIWindow, fRameWindow
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_ShowContextMenu(ByVal dwContext As olelib.ContextMenuTarget, pPOINT As olelib.POINT, ByVal pCommandTarget As , ByVal HTMLTagElement As Object)
' IDocHostUIHandler.ShowContextMenu dwContext, pPOINT, pCommandTarget, HTMLTagElement
' Err.Raise E_NOTIMPL
''禁止右键菜单===>成功!
End Sub
Private Sub IDocHostUIHandler_ShowUI(ByVal dwID As Long, ByVal pActiveObject As , ByVal pCommandTarget As , ByVal pFrame As , ByVal pDoc As )
' IDocHostUIHandler.ShowUI dwID, pActiveObject, pCommandTarget, pFrame, pDoc
' Err.Raise E_NOTIMPL
End Sub
Private Sub IDocHostUIHandler_TranslateAccelerator(lpMsg As olelib.MSG, pguidCmdGroup As olelib.UUID, ByVal nCmdID As Long)
' IDocHostUIHandler.TranslateAccelerator lpMsg, pguidCmdGroup, nCmdID
' Err.Raise E_NOTIMPL
End Sub
Private Function IDocHostUIHandler_TranslateUrl(ByVal dwTranslate As Long, ByVal pchURLIn As Long) As Long
' IDocHostUIHandler_TranslateUrl = IDocHostUIHandler.TranslateUrl(dwTranslate, pchURLIn)
' Err.Raise E_NOTIMPL
End Function
Private Sub IDocHostUIHandler_UpdateUI()
' 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 ptY As Long, pdwEffect As olelib.DROPEFFECTS)
Form1.Caption = "iDropTarget_DragEnter>>" & Timer
End Sub
Private Sub iDropTarget_DragLeave()
Form1.Caption = "iDropTarget_DragLeave>>" & Timer
End Sub
Private Sub iDropTarget_DragOver(ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As olelib.DROPEFFECTS)
Form1.Caption = "iDropTarget_DragOver>>" & Timer
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)
Form1.Caption = "iDropTarget_Drop>>" & Timer
End Sub