浏览器

开发平台：
Visual Basic

DataObjectWB.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 = "DataObjectWB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*********************************************************************************************
'
' Customizing the WebBrowser control
'
' WB Customizer DataObject
'
'*********************************************************************************************
'
' Author: Eduardo Morcillo
' E-Mail: edanmo@geocities.com
' Web Page: http://www.domaindlx.com/e_morcillo
'
' Created: 03/25/2000
'
'*********************************************************************************************
Option Explicit
Private Const cfhtml_Tag_Start$ = "<!--StartFragment-->"
Private Const cfhtml_Tag_End$ = "<!--EndFragment-->"
Private Const cfhtml_Tag_SourceURL$ = "SourceURL:"
Dim m_DragDropDataObject As IDataObject
'
' pvStringFromhGlobal
'
' Returns a string from a global memory handle
'
Private Function pvStringFromhGlobal(ByVal hGlobal As Long) As String
Dim PtrStr As Long
   PtrStr = GlobalLock(hGlobal)
   pvStringFromhGlobal = String$(lstrlen(PtrStr), 0)
   MoveMemory ByVal pvStringFromhGlobal, ByVal PtrStr, Len(pvStringFromhGlobal)
   GlobalUnlock hGlobal
End Function
'
' GetText
'
' Returns the dragged URL/Text
'
Public Function GetText() As String
Dim rtn$
Dim FMT As FORMATETC, STM As STGMEDIUM
'Dim Enm As IEnumFORMATETC
   ' Format is IGNORED!!!!
   With FMT
      .cfFormat = CF_URL
      .TYMED = TYMED_HGLOBAL
      .dwAspect = DVASPECT_CONTENT
      .lindex = -1
   End With
   ' Try to get the URL (this will fail with
   ' files dragged to the control)
   If m_DragDropDataObject.GetData(FMT, STM) = 0 Then
      ' The user is dragging a link
      ' Get the URL from the
      ' global handle
      rtn = StrConv(pvStringFromhGlobal(STM.Data), vbUnicode)
      ReleaseStgMedium STM
   Else
      With FMT
         .cfFormat = vbCFText
         .TYMED = TYMED_HGLOBAL
         .dwAspect = DVASPECT_CONTENT
         .lindex = -1
      End With
      If m_DragDropDataObject.GetData(FMT, STM) = 0 Then
         ' The user is dragging text
         ' Get the text from the
         ' global handle
         rtn = StrConv(pvStringFromhGlobal(STM.Data), vbUnicode)
         ReleaseStgMedium STM
      End If
   End If
If rtn <> "" Then
    If Asc(Right(rtn, 1)) = 0 Then
        rtn = Left(rtn, Len(rtn) - 1)
    End If
End If
GetText = rtn
End Function
'
' Files
'
' Returns a collection filled with
' the dragged file names
'
Public Property Get Files() As Collection
Dim STM As STGMEDIUM, FMT As FORMATETC
Dim lMaxIdx As Long, lIdx As Long
Dim sFile As String, lLen As Long
   ' Create a mew collection
   Set Files = New Collection
   ' Fill the FORMATETC struct
   ' to retrieve the filename
   ' data in CF_HDROP format
   With FMT
      .cfFormat = CF_HDROP
      .TYMED = TYMED_HGLOBAL
      .dwAspect = DVASPECT_CONTENT
      .lindex = -1
   End With
   ' Get the data from IDataObject
   ' This call will fill the STM
   ' struct with a pointer to
   ' the DROPFILES struct
   If m_DragDropDataObject.GetData(FMT, STM) = 0 Then
      ' Get file name count
      lMaxIdx = DragQueryFile(STM.Data, -1, vbNullString, 0)
      ' Get filenames
      For lIdx = 0 To lMaxIdx - 1
         sFile = String$(260, 0)
         ' Get the file name
         lLen = DragQueryFile(STM.Data, lIdx, sFile, Len(sFile))
         sFile = StrConv(Left$(sFile, lLen), vbNarrow)
         ' Add the file name to the
         ' collection
         Files.Add sFile
      Next
      ' Release memory used by
      ' STM.Data
      ReleaseStgMedium STM
   End If
End Property
'
' IDataObject
'
' Sets the IDataObject that contains the data
Friend Property Set IDataObject(ByVal IDO As IDataObject)
   Set m_DragDropDataObject = IDO
End Property
'---------------------------------------------------------------------------------------
' Procedure : GetImageUrl
' DateTime  : 2005-5-9 23:46
' Author    : Lingll
' Purpose   : 获得img的url,供外部使用
'---------------------------------------------------------------------------------------
Public Function GetImageUrl() As String
Dim tHtml$, tFrag$, tSUrl$
Dim tPos&
tHtml = GetCFHtml()
tFrag = GetFragment(tHtml)
tSUrl = GetSourceURL(tHtml)
tPos = IsImageDrop(tFrag)
If tPos > 0 Then
    GetImageUrl = GetImgUrl(tSUrl, tFrag)
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetImgUrl
' DateTime  : 2005-5-10 15:55
' Author    : Lingll
' Purpose   : 获得img的url,供内部使用
'---------------------------------------------------------------------------------------
Private Function GetImgUrl(vUrl$, vHtml$) As String
On Error Resume Next
    Dim tPos1&, tPos2&, tPos3&
    Dim tOrgSrc$
    
    tPos1 = InStr(1, vHtml, "<IMG ", vbTextCompare)
    If tPos1 > 0 Then
        tPos1 = InStr(tPos1 + 1, vHtml, "src=", vbTextCompare)
        tPos3 = InStr(tPos1, vHtml, ">", vbTextCompare)
        If tPos1 > 0 Then
            Select Case Mid$(vHtml, tPos1 + 4, 1)
                Case "'"
                    tPos2 = InStr(tPos1 + 5, vHtml, "'")
                    If tPos2 > 0 And tPos2 < tPos3 Then
                        tOrgSrc = Mid$(vHtml, tPos1 + 5, tPos2 - tPos1 - 5)
                    End If
                Case """"
                    tPos2 = InStr(tPos1 + 5, vHtml, """")
                    If tPos2 > 0 And tPos2 < tPos3 Then
                        tOrgSrc = Mid$(vHtml, tPos1 + 5, tPos2 - tPos1 - 5)
                    End If
                Case Else
                    tPos2 = InStr(tPos1 + 1, vHtml, " ")
                    If tPos2 <= 0 Or tPos2 > tPos3 Then
                        tPos2 = tPos3
                    End If
                    tOrgSrc = Mid$(vHtml, tPos1 + 4, tPos2 - tPos1 - 4)
            End Select
            
            If tOrgSrc <> vbNullString Then
                GetImgUrl = GetRealUrl(vUrl, tOrgSrc)
            End If
        End If
    End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetRealUrl
' DateTime  : 2005-5-10 16:21
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Function GetRealUrl(ByVal vSrcUrl$, ByVal vOrgUrl$) As String
Dim tPos1&, tPos1Pre&, tPos2&, tPosStart&
If InStr(1, vOrgUrl, "://") > 0 Then
    GetRealUrl = vOrgUrl
ElseIf InStr(1, vOrgUrl, ":") > 0 Then
    GetRealUrl = vOrgUrl
Else
    vOrgUrl = Replace(vOrgUrl, "", "/")
    vSrcUrl = Replace(vSrcUrl, "", "/")
    If Right$(vSrcUrl, 1) <> "/" Then
        tPos1 = InStrRev(vSrcUrl, "/")
        If tPos1 > 0 Then
            vSrcUrl = Left$(vSrcUrl, tPos1)
        End If
    End If
    tPosStart = InStr(1, vSrcUrl, "://")
    tPos1 = InStr(1, vOrgUrl, "../")
    tPos1Pre = 0
    tPos2 = Len(vSrcUrl)
    While tPos1 > 0
        tPos2 = InStrRev(vSrcUrl, "/", tPos2 - 1)
        
        tPos1Pre = tPos1
        tPos1 = InStr(tPos1 + 1, vOrgUrl, "../")
    Wend
    If tPos1Pre > 0 Then
        GetRealUrl = Left$(vSrcUrl, tPos2) & Replace(Mid$(vOrgUrl, tPos1Pre + 3), "./", "")
    ElseIf tPos1Pre = 0 Then
        GetRealUrl = vSrcUrl & Replace(vOrgUrl, "./", "")
    End If
End If
End Function
''---------------------------------------------------------------------------------------
'' Procedure : GetUrlFolder
'' DateTime  : 2005-5-10 17:04
'' Author    : Lingll
'' Purpose   : 获取url中/分隔的部分(此函数为反向顺序)
''---------------------------------------------------------------------------------------
'Private Function GetUrlFolderRev(ByVal vUrl$, vPos&) As String
'Dim tPosStart&
'Dim tPos1&
'Dim tArr() As String
'
'If Right$(vUrl, 1) = "/" Then
'    vUrl = Left$(vUrl, Len(vUrl) - 1)
'End If
'
'tPosStart = InStr(1, vUrl, "://")
'If tPosStart > 0 Then
'    tPosStart = tPosStart + 3
'Else
'    tPosStart = 1
'End If
'
'tPos1 = InStr(tPosStart, vUrl, "/")
'If tPos1 > 0 Then
'    tArr = Split(Mid$(vUrl, tPos1 + 1), "/")
'    Select Case vPos
'        Case Is <= UBound(tArr) + 1
'            GetUrlFolderRev = tArr(UBound(tArr) + 1 - vPos) & "/"
'        Case UBound(tArr) + 2
'            GetUrlFolderRev = Left$(vUrl, tPos1 - 1) & "/"
'        Case Else
'            GetUrlFolderRev = ""
'    End Select
'Else
'    If vPos = 1 Then
'        GetUrlFolderRev = vUrl & "/"
'    Else
'        GetUrlFolderRev = ""
'    End If
'End If
'
'End Function
'---------------------------------------------------------------------------------------
' Procedure : GetCFHtml
' DateTime  : 2005-5-10 15:50
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Public Function GetCFHtml() As String
    Dim tArr() As Byte
    Dim tstr$
    Dim FMT As FORMATETC, STM As STGMEDIUM
    With FMT
       .cfFormat = CF_HTML
       .TYMED = TYMED_HGLOBAL
       .dwAspect = DVASPECT_CONTENT
       .lindex = -1
    End With
   
    If m_DragDropDataObject.GetData(FMT, STM) = 0 Then
       'GetCFHtml = StrConv(pvStringFromhGlobal(STM.Data), vbUnicode)
       tArr = pvStringFromhGlobal(STM.Data)
       GetCFHtml = UTF8_Decode(tArr)
       ReleaseStgMedium STM
    End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetFragment
' DateTime  : 2005-5-9 23:52
' Author    : Lingll
' Purpose   : 获得在 "<!--StartFragment-->","<!--EndFragment-->"之间的东西
'---------------------------------------------------------------------------------------
Public Function GetFragment(vHtml$) As String
    Dim tPos1&, tPos2&
    
    tPos1 = InStr(1, vHtml, cfhtml_Tag_Start, vbTextCompare)
    If tPos1 > 0 Then
        tPos2 = InStr(tPos1, vHtml, cfhtml_Tag_End, vbTextCompare)
        If tPos2 > 0 Then
            GetFragment = Mid$(vHtml, tPos1 + Len(cfhtml_Tag_Start), tPos2 - tPos1 - Len(cfhtml_Tag_Start))
        End If
    End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetSourceURL
' DateTime  : 2005-5-10 16:02
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Function GetSourceURL(vHtml$) As String
    Dim tPos1&, tPos2&
    tPos1 = InStr(1, vHtml, cfhtml_Tag_SourceURL, vbTextCompare)
    If tPos1 > 0 Then
        tPos2 = InStr(tPos1, vHtml, vbNewLine)
        If tPos2 > 0 Then
            GetSourceURL = Mid$(vHtml, tPos1 + Len(cfhtml_Tag_SourceURL), tPos2 - tPos1 - Len(cfhtml_Tag_SourceURL))
        End If
    End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : IsImageDrop
' DateTime  : 2005-5-9 23:57
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Public Function IsImageDrop(vImghtml$) As Long
Dim FMT As FORMATETC
    With FMT
       .cfFormat = vbCFDIB
       .TYMED = TYMED_HGLOBAL
       .dwAspect = DVASPECT_CONTENT
       .lindex = -1
    End With
    If m_DragDropDataObject.QueryGetData(FMT) = 0 Then
        IsImageDrop = InStr(1, vImghtml, "<IMG ", vbTextCompare)
    Else
        IsImageDrop = 0
    End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetHtmlTag
' DateTime  : 2005-5-10 18:38
' Author    : Lingll
' Purpose   : url,text,img
'---------------------------------------------------------------------------------------
Public Function GetHtmlDragDropType() As String
Dim FMT As FORMATETC
Dim isHtml As Boolean, isDIB As Boolean, isUrl As Boolean, isText As Boolean
With FMT
   .TYMED = TYMED_HGLOBAL
   .dwAspect = DVASPECT_CONTENT
   .lindex = -1
End With
FMT.cfFormat = CF_HTML
isHtml = (m_DragDropDataObject.QueryGetData(FMT) = 0)
FMT.cfFormat = vbCFDIB
isDIB = (m_DragDropDataObject.QueryGetData(FMT) = 0)
FMT.cfFormat = CF_URL
isUrl = (m_DragDropDataObject.QueryGetData(FMT) = 0)
FMT.cfFormat = vbCFText
isText = (m_DragDropDataObject.QueryGetData(FMT) = 0)
If isHtml And isDIB Then
    GetHtmlDragDropType = "img"
ElseIf isUrl Then
    GetHtmlDragDropType = "url"
ElseIf isText Then
    GetHtmlDragDropType = "text"
End If
End Function

						