[VB6] Register any control as a drop target that shows the Explorer drag image

[fafalone]

Well... this looks fun.

In the case of CF_DIB, an hDIB is stored as hGlobal. GlobalLock on that hGlobal will produce a pointer to a BITMAPINFOHEADER structure. So that should produce all the info required to draw it to an hDC. I'll need a little time to work out the details on that.

CF_TEXT is easier; it's also stored as hGlobal, but it's far easier to turn a pointer to a string into a VB-usable string:

   Dim tSTG As STGMEDIUM
   Dim tFMT As FORMATETC
   tFMT.cfFormat = CF_TEXT
   tFMT.dwAspect = DVASPECT_CONTENT
   tFMT.TYMED = TYMED_HGLOBAL
   tFMT.lIndex = -1
   
   If pDataObj.QueryGetData(tFMT) = S_OK Then
    Debug.Print "got text drop"
    pDataObj.GetData tFMT, tSTG
    Dim lpText As Long
    lpText = GlobalLock(tSTG.Data)
    Debug.Print GetStrFromPtrA(lpText)
    Call GlobalUnlock(tSTG.Data)
    ReleaseStgMedium tSTG
    Exit Sub
  Else
    Debug.Print "failed cf_text"
  End If

And for Unicode support:

   Dim tSTG As STGMEDIUM
   Dim tFMT As FORMATETC
   tFMT.cfFormat = CF_UNICODETEXT
   tFMT.dwAspect = DVASPECT_CONTENT
   tFMT.TYMED = TYMED_HGLOBAL
   tFMT.lIndex = -1
   
   If pDataObj.QueryGetData(tFMT) = S_OK Then
    Debug.Print "got unicode text drop"
    pDataObj.GetData tFMT, tSTG
    Dim lpText As Long
    lpText = GlobalLock(tSTG.Data)
    Debug.Print LPWSTRtoStr(lpText, False)
    Call GlobalUnlock(tSTG.Data)
    ReleaseStgMedium tSTG
    Exit Sub
  Else
    Debug.Print "failed cf_unitext"
  End If

APIs and String-from-pointer functions:

Public Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell
Public Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long
Public Declare Function lstrcpyA Lib "kernel32" (lpString1 As Any, lpString2 As Any) As Long
Public Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Public Const CF_TEXT = 1
Public Const CF_BITMAP = 2
Public Const CF_METAFILEPICT = 3
Public Const CF_SYLK = 4
Public Const CF_DIF = 5
Public Const CF_TIFF = 6
Public Const CF_OEMTEXT = 7
Public Const CF_DIB = 8
Public Const CF_PALETTE = 9
Public Const CF_PENDATA = 10
Public Const CF_RIFF = 11
Public Const CF_WAVE = 12
Public Const CF_UNICODETEXT = 13
Public Const CF_ENHMETAFILE = 14
Public Const CF_HDROP = 15
Public Const CF_LOCALE = 16
Public Const CF_DIBV5 = 17


Public Function GetStrFromPtrA(lpszA As Long) As String
  Dim sRtn As String
  sRtn = String$(lstrlenA(ByVal lpszA), 0)
  Call lstrcpyA(ByVal sRtn, ByVal lpszA)
  GetStrFromPtrA = sRtn
End Function

Public Function LPWSTRtoStr(lPtr As Long, Optional ByVal fFree As Boolean = True) As String
SysReAllocString VarPtr(LPWSTRtoStr), lPtr
If fFree Then
    Call CoTaskMemFree(lPtr)
End If
End Function