[VB6] Drag drop any format to other apps without custom IDataObject

[fafalone]

3 Aug 2016 UPDATE: This is fairly complex stuff so I've added a sample project. The sample project also has functions for added a few more formats, and receives text too. An updated cDropTarget class was made more portable and easy to use; it's not the super-involved one I'm working on, it just pushes events out with the IDataObject for the project to handle elsewhere. Also, dropping PNGs in the same process they were created in caused a heap corruption crash, this has been fixed by making the dataobject module-level so it doesn't prematurely go out of scope and get freed.

While I've got a thread going about how to do this the right way and actually implement an IDataObject, in the mean time I thought I'd post a trick that you can use to dragdrop any format without one.

Normally, to drag text to another app, you'd have to create an implementation of IDataObject in a class, then implement all its methods and support CF_TEXT and/or CF_UNICODETEXT and others you wanted. However, if you were just looking to copy files with CF_HDROP, you may have seen my other project where there's an API that does this for you-- SHCreateDataObject. There's not a direct equivalent for any other CF_ format, but it turns out that you can call that API without actually specifying a file, and still get back a fully functional default IDataObject from Windows instead of rolling your own custom one, which you can then add your desired formats to. This is still far less code and far easier than providing a custom implementation.

Requirements
-Windows Vista or higher*
-oleexp.tlb version 4.0 or higher with mIID.bas

Code
Primary code to create and drag, typically called from a MouseDown event:

Public Declare Function SHCreateDataObject Lib "shell32" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pdtInner As Any, riid As UUID, ppv As Any) As Long
Public Declare Function SHDoDragDrop Lib "shell32" (ByVal hwnd As Long, ByVal pdtobj As Long, ByVal pdsrc As Long, ByVal dwEffect As Long, pdwEffect As Long) As Long

Public Sub DoDrag()
Dim pDataObj As oleexp.IDataObject

Call SHCreateDataObject(0&, 0&, 0&, ByVal 0&, IID_IDataObject, pDataObj)

If (pDataObj Is Nothing) Then
    Debug.Print "couldn't get ido"
Else
    Debug.Print "got ido"
    IDO_AddTextW pDataObj, "TextWTest"
    IDO_AddTextA pDataObj, "TextATest"
    Dim lp As Long
    Dim hr As Long
    hr = SHDoDragDrop(Me.hwnd, ObjPtr(pDataObj), 0&, DROPEFFECT_COPY, lp)
    Set pDataObj = Nothing
End If
End Sub

The example above adds two formats to the blank IDataObject, CF_TEXT (IDO_AddTextA) and CF_UNICODETEXT (IDO_AddTextW):

Public Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Public Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) 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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Sub IDO_AddTextW(ido As oleexp3.IDataObject, sText As String)
Dim fmt As FORMATETC
Dim stg As STGMEDIUM
Dim hGlobal As Long, lpGlobal As Long
Dim sz As String
sz = sText & vbNullChar
hGlobal = GlobalAlloc(GPTR, LenB(sz))
If hGlobal Then
    lpGlobal = GlobalLock(hGlobal)
    Call CopyMemory(ByVal lpGlobal, ByVal StrPtr(sz), LenB(sz))
    Call GlobalUnlock(hGlobal)
    stg.TYMED = TYMED_HGLOBAL
    stg.Data = lpGlobal
    fmt.cfFormat = CF_UNICODETEXT
    fmt.dwAspect = DVASPECT_CONTENT
    fmt.lIndex = -1
    fmt.TYMED = TYMED_HGLOBAL
    ido.SetData fmt, stg, 1
End If

End Sub
Public Sub IDO_AddTextA(ido As oleexp.IDataObject, sText As String)
Dim fmt As FORMATETC
Dim stg As STGMEDIUM
Dim hGlobal As Long, lpGlobal As Long
Dim b() As Byte

hGlobal = GlobalAlloc(GPTR, Len(sText) + 1)
If hGlobal Then
    lpGlobal = GlobalLock(hGlobal)
    b = StrConv(sText & vbNullChar, vbFromUnicode)
    CopyMemory ByVal lpGlobal, b(0), UBound(b) + 1
    Call GlobalUnlock(hGlobal)
    stg.TYMED = TYMED_HGLOBAL
    stg.Data = lpGlobal
    fmt.cfFormat = CF_TEXT
    fmt.dwAspect = DVASPECT_CONTENT
    fmt.lIndex = -1
    fmt.TYMED = TYMED_HGLOBAL
    ido.SetData fmt, stg, 1
End If
End Sub

You can follow the same basic procedure to add any formats you want to your IDataObject. As another example, here's how to drag a PNG image from the file on disk, which shows the technique for dragging file contents:

Public Declare Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As Long) As Long
Public Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Public Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Public Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Const FILE_READ_DATA = &H1
Public Const FILE_SHARE_READ = &H1&
Public Const OPEN_EXISTING = 3&

Public Sub IDO_AddPNG(pDataObj As oleexp.IDataObject, sPng As String)
Dim fmt As FORMATETC
Dim stg As STGMEDIUM
Dim hGlobal As Long, lpGlobal As Long
Dim hFile As Long, nFile As Long, lp As Long
Dim bPNG() As Byte
hFile = CreateFileW(StrPtr(sPng), FILE_READ_DATA, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
If hFile Then
    nFile = GetFileSize(hFile, lp)
    Debug.Print "high=" & nFile & ",low=" & lp
    ReDim bPNG(nFile)
    ReadFile hFile, bPNG(0), nFile, lp, 0&
    CloseHandle hFile
    If lp > 0& Then

    hGlobal = GlobalAlloc(GPTR, UBound(bPNG) + 1)
    If hGlobal Then
        lpGlobal = GlobalLock(hGlobal)
        CopyMemory ByVal lpGlobal, bPNG(0), UBound(bPNG) + 1
        Call GlobalUnlock(hGlobal)
        stg.TYMED = TYMED_HGLOBAL
        stg.Data = lpGlobal
        fmt.cfFormat = RegisterClipboardFormatW(StrPtr(CFSTR_PNG))
        fmt.dwAspect = DVASPECT_CONTENT
        fmt.lIndex = -1
        fmt.TYMED = TYMED_HGLOBAL
        pDataObj.SetData fmt, stg, 1
    End If 'memalloc

    End If 'bytesread>0
End If
End Sub

You can add multiple formats to the same object; it's the drop target that decides which it can accept and display.

Since it's a custom format, we don't get the benefit of a default icon anymore. But making a drag image isn't too hard; we can use the IDragSourceHelper interface for that. If you've got a control you're dragging from that does drag images, you can use InitializeFromWindow, but if you want full control you can create the entire image yourself. Here's an IDO_AddPNGEx routine that does just that:

Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Declare Function SHCreateItemFromIDList Lib "shell32" (ByVal pidl As Long, riid As UUID, ppv As Any) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell

Public Sub IDO_AddPNGEx(pDataObj As oleexp.IDataObject, sPng As String)
Dim fmt As FORMATETC
Dim stg As STGMEDIUM
Dim hGlobal As Long, lpGlobal As Long
Dim lpFmt As Long
Dim hFile As Long, nFile As Long, lp As Long
Dim bPNG() As Byte
hFile = CreateFileW(StrPtr(sPng), FILE_READ_DATA, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
If hFile Then
    nFile = GetFileSize(hFile, lp)
    Debug.Print "high=" & nFile & ",low=" & lp
    ReDim bPNG(nFile)
    ReadFile hFile, bPNG(0), nFile, lp, 0&
    CloseHandle hFile
    If lp > 0& Then
        hGlobal = GlobalAlloc(GPTR, UBound(bPNG) + 1)
        If hGlobal Then
            lpGlobal = GlobalLock(hGlobal)
            CopyMemory ByVal lpGlobal, bPNG(0), UBound(bPNG) + 1
            Call GlobalUnlock(hGlobal)
            stg.TYMED = TYMED_HGLOBAL
            stg.Data = lpGlobal
            fmt.cfFormat = CF_PNG
            fmt.dwAspect = DVASPECT_CONTENT
            fmt.lIndex = -1
            fmt.TYMED = TYMED_HGLOBAL
            pDataObj.SetData fmt, stg, 1
            
            'set thumbnail for drag
            Dim pHelper As IDragSourceHelper2
            Set pHelper = New DragDropHelper
            Dim tImg As SHDRAGIMAGE
            GetFileThumbForIDSH sPng, tImg
            pHelper.SetFlags 0&
            pHelper.InitializeFromBitmap tImg, pDataObj
        End If
    End If
End If
End Sub
Private Sub GetFileThumbForIDSH(sFile As String, tSDI As SHDRAGIMAGE, Optional cx As Long = 16, Optional cy As Long = 16)
'This method is Vista-only; you can fall back to IExtractImage or others if you're trying to support XP still
Dim pidl As Long
Dim isiif As IShellItemImageFactory
pidl = ILCreateFromPathW(StrPtr(sFile))
Call SHCreateItemFromIDList(pidl, IID_IShellItemImageFactory, isiif)
If (isiif Is Nothing) = False Then
    isiif.GetImage cx, cy, SIIGBF_THUMBNAILONLY, tSDI.hbmpDragImage
    tSDI.sizeDragImage.cx = cx
    tSDI.sizeDragImage.cy = cy
'        tSDI.ptOffset.x = 15 'you can add an offset to see it better, but the drop x,y won't change
'        tSDI.ptOffset.Y = 15
Else
    Debug.Print "GetFileThumbForIDSH::Failed to get IShellItemImageFactory"
End If
Call CoTaskMemFree(pidl)
End Sub

A 32x32 drag image thumbnail of a PNG being dragged, next to it after being dropped and rendered at full size (see next post):


And finally, you can also set a default drop description (although drop targets frequently set their own):

First, in IDO_AddPNGEx, change pHelper.SetFlags 0& to pHelper.SetFlags DSH_ALLOWDROPDESCRIPTIONTEXT
Then immediately after IDO_AddPNGEx, add IDO_AddDropDesc pDataObj, DROPIMAGE_LABEL, "Drop %1 here", "MyPNG"

Public Sub IDO_AddDropDesc(ido As oleexp.IDataObject, nType As DROPIMAGETYPE, sMsg As String, sIns As String)
Dim fmt As FORMATETC
Dim stg As STGMEDIUM
Dim tDD As DROPDESCRIPTION
Dim iTmp1() As Integer
Dim iTmp2() As Integer
Dim hGlobal As Long, lpGlobal As Long
Dim i As Long
On Error GoTo e0

Str2WCHAR sMsg, iTmp1
Str2WCHAR sIns, iTmp2

For i = 0 To UBound(iTmp1)
    tDD.szMessage(i) = iTmp1(i)
Next i

For i = 0 To UBound(iTmp2)
    tDD.szInsert(i) = iTmp2(i)
Next i
tDD.type = nType

hGlobal = GlobalAlloc(GHND, LenB(tDD))
If hGlobal Then
    lpGlobal = GlobalLock(hGlobal)
    Call CopyMemory(ByVal lpGlobal, tDD, LenB(tDD))
    Call GlobalUnlock(hGlobal)
    stg.TYMED = TYMED_HGLOBAL
    stg.Data = lpGlobal
    fmt.cfFormat = RegisterClipboardFormatW(StrPtr(CFSTR_DROPDESCRIPTION)) 'CF_DROPDESCRIPTION
    fmt.dwAspect = DVASPECT_CONTENT
    fmt.lIndex = -1
    fmt.TYMED = TYMED_HGLOBAL
    ido.SetData fmt, stg, 1
End If
Exit Sub
e0:
    Debug.Print "IDO_AddDropDesc->" & Err.Description
End Sub
Private Sub Str2WCHAR(sz As String, iOut() As Integer)
Dim i As Long
ReDim iOut(255)
For i = 1 To Len(sz)
    iOut(i - 1) = AscW(Mid(sz, i, 1))
Next i
End Sub

--------------------------------
* - Normally I would use the undocumented SHCreateFileDataObject and retain XP support, but with this usage the IDataObject it creates returns with several additional formats inserted with blank or corrupt data. If XP support is a requirement you can try it and see if the form