1 Attachment(s)
[VB6] Drag drop any format to other apps without custom IDataObject
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:
Code:
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):
Code:
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:
Code:
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:
Code:
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):
http://i.imgur.com/uQxkyh9.jpg
And finally, you can also set a default drop description (although drop targets frequently set their own):
http://i.imgur.com/9rD4iSe.jpg
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"
Code:
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
Re: [VB6] Code Snippet: Drag drop any format to other apps without custom IDataObject
For those curious, also wanted to show how you could accept a dragged PNG and show it in a Picturebox, when your control is registered as a modern IDropTarget:
Code:
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As Any) As Long ' lpPoint As POINTAPI) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GdipLoadImageFromStream Lib "GDIplus" (ByVal stream As IUnknown, Image As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "GdiPlus.dll" (ByVal hDC As Long, GpGraphics As Long) As Long
Private Declare Function GdipGetImageWidth Lib "GdiPlus.dll" (ByVal Image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "GdiPlus.dll" (ByVal Image As Long, Height As Long) As Long
Private Declare Function GdipDrawImageRectRectI Lib "GdiPlus.dll" (ByVal graphics As Long, ByVal GpImage As Long, ByVal dstx As Long, ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal srcx As Long, ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As Long, ByVal imageAttributes As Long, ByVal callback As Long, ByVal callbackData As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal graphics As Long) As Long
Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal Image As Long) As Long
Private Declare Function GdiplusStartup Lib "GDIplus" (ByRef Token As Long, ByRef lpInput As GdiplusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "GDIplus" (ByVal Token As Long) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Const RDW_UPDATENOW As Long = &H100
Private Const RDW_INVALIDATE As Long = &H1
Private Const RDW_ERASE As Long = &H4
Private Const RDW_ALLCHILDREN As Long = &H80
Private Function DoDrop_PNG(pDataObj As oleexp.IDataObject, pt As oleexp.POINT) As Long
Dim tFMT As FORMATETC
Dim tSTG As STGMEDIUM
Dim lpGlobal As Long
Dim hGlobal As Long
'if you want the coords of the mouse on the control:
Dim pt2 As oleexp.POINT
pt2.x = pt.x
pt2.Y = pt.Y
ScreenToClient Picture1.hWnd, pt2
tFMT.cfFormat = RegisterClipboardFormatW(StrPtr(CFSTR_PNG)) 'CF_PNG
tFMT.dwAspect = DVASPECT_CONTENT
tFMT.lIndex = -1
tFMT.TYMED = TYMED_HGLOBAL
Debug.Print "Got PNG drop"
pDataObj.GetData tFMT, tSTG
If tSTG.Data Then
hGlobal = tSTG.Data
lpGlobal = GlobalLock(hGlobal)
Dim pIStrm As IStream
Dim hImage As Long
Dim hGraphics As Long
Dim CX As Long, CY As Long
Call CreateStreamOnHGlobal(hGlobal, 1, pIStrm)
If (pIStrm Is Nothing) Then
Debug.Print "DoDrop_PNG::Failed to create IStream"
Exit Function
End If
GdipLoadImageFromStream pIStrm, hImage
If GdipCreateFromHDC(Picture1.hDC, hGraphics) = 0 Then
GdipGetImageWidth hImage, CX
GdipGetImageHeight hImage, CY
' GdipDrawImageRectRectI hGraphics, hImage, 0, 0, CX, CY, 0, 0, CX, CY, &H2, 0, 0&, 0& 'Render at 0,0
GdipDrawImageRectRectI hGraphics, hImage, pt2.x, pt2.Y, CX, CY, 0, 0, CX, CY, &H2, 0, 0&, 0& 'render at mouse position
GdipDeleteGraphics hGraphics
End If
GdipDisposeImage hImage
RedrawWindow Picture1.hWnd, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN
UpdateWindow Picture1.hWnd
GlobalUnlock hGlobal
End If
ReleaseStgMedium tSTG
End Function
Re: [VB6] Drag drop any format to other apps without custom IDataObject
UPDATED
Since this is so complex I've turned it into a full sample project, hopefully that will make this technique more accessible.
Also a few bug fixes to the original code posted; see post #1.
