[VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDrop
API File Dragging
Project Updated to Revision 3 on May 5th, 2020
It took many months of wasting hours, giving up, and revisiting to finally get a working solution, and the only previous VB solution was monstrously complex. I understand very few people will find this useful, but wanted to share anyway due to the lack of answers I found while trying to get it working and the simplicity over other solutions.
NEW: A NOTE ON DRAG IMAGES
The project hasn't been updated, but I wanted to add on some new information about the drag image. As you may have noted, multiple files just have the number without the icon unless you drag over certain apps, and the modern drag image doesn't show at all in the source control. These are both caused by the same thing: a modern drag source like ours is also supposed to use the latest drop target functionality. If you register your control as a drop target with the modern methods (see this project), the 100%-identical-to-Explorer image for multiple files will show from the start now and carry over to Explorer. You don't need to actually allow drop functionality; a registered drop target whose effect is DROP_EFFECT_NONE is just as good.
Background
DragDrop functionality is easy if you're using, say, VB's ListView, but what if you're using a ListView created via CreateWindowEx that has no OLEStartDrag/OLESetData with pre-provided DataObject, and want to start a drag operation that can be dragged around Windows Explorer (or any drop target accepting dropped files)? Previous solutions have used the DoDragDrop API and then had to implement their own IDataObject and IDropSource interfaces, and I had yet to see one that supported multiple paths. Turns out that unless you require other-than-default behavior, you accomplish a full drag-to-explorer operation in just a few lines of code. The SHDoDragDrop API provides both a default drag source and a default drag icon showing the number of files, just like Explorer. It also supports the action options menu if you drag with the right button. And no further action is required, the receiving program handles the operation.
The included sample project doesn't use any subclassed/CreateWindowEx ListViews, but does show how you can initiate the operation from any arbitary point in code given a list of files.
This project originally used an API to create the IDataObject. The latest version uses a far superior method, but it requires Windows Vista or newer. If you need to retain Windows XP support, you can use the legacy method with an undocumented API. Simply replace the 2 IShellItemArray lines with a call to this API:
Code:
Public Declare Function SHCreateFileDataObject Lib "shell32" Alias "#740" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pDataInner As Any, ppDataObj As oleexp.IDataObject) As Long
Call SHCreateFileDataObject(VarPtr(0&), cpidl, VarPtr(apidl(0)), ByVal 0&, iData)
Also see below for voxy's post on how to add even more formats manually by using the IDataObject.SetData method.
Requirements
Windows Vista or newer. If you replace the IDataObject creation method with the legacy method posted above, Windows XP or newer.
Attached project references oleexp.tlb v4.0 or higher. The legacy method requires only one of the several typelibs that include an IDataObject definition.
For the purposes of the below code, we'll assume you have your own routine to enumerate the full paths of the files that are selected. This code will typically be for a Begin Drag notification, such as LVN_BEGINDRAG.
Code:
Public Sub InitDrag(sSelFullPath() As String)
Dim hr0 As Long
Dim iData As IDataObject
Dim psia As IShellItemArray
Dim apidl() As Long
Dim cpidl As Long
Dim rpidl As Long
Dim pidlDesk As Long
Dim lRetDD As Long
Dim i As Long
Dim AllowedEffects As DROPEFFECTS
'EnumSelectedFiles - Whatever routine you have to get your selected files list, a standard routine like
' Do
' i = ListView_GetNextItem(hLVS, i, LVNI_SELECTED)
' If (i <> LVI_NOITEM) Then
ReDim apidl(UBound(sSelFullPath)) 'sSelFullPath would then contain the full path to the file, C:\folder\file.ext, //Computer/folder/file.ext
For i = 0 To UBound(apidl)
apidl(i) = GetPIDLFromPathW(sSelFullPath(i)) 'support function to return fully qualified pidls for each file, see below
Next i
cpidl = UBound(apidl) + 1
oleexp.SHCreateShellItemArrayFromIDLists cpidl, VarPtr(apidl(0)), psia
If psia Is Nothing Then
Debug.Print "Failed to create IShellItemArray"
Exit Sub
End If
psia.BindToHandler 0&, BHID_DataObject, IID_IDataObject, iData
If iData Is Nothing Then
Debug.Print "Failed to created IDataObject"
Exit Sub
End If
AllowedEffects = DROPEFFECT_COPY Or DROPEFFECT_MOVE Or DROPEFFECT_LINK
hr0 = SHDoDragDrop(0&, ObjPtr(iData), 0, AllowedEffects, lRetDD) 'theoretically you can supply your own IDropSource implementation, but I never got it working
Debug.Print "hr0=" & hr0 & ",lRet=" & lRetDD 'hr0 contains the HRESULT of the call, and lRetDD is the result of the operation, see the full DROPEFFECT description for all possible values
Call CoTaskMemFree(pidlDesk)
For i = 0 To UBound(apidl)
Call CoTaskMemFree(apidl(i))
Next i
Set iData = Nothing
End Sub
'If instead this is in a WndProc, you'll probably want to cancel the notification by returning 1 and exiting before a DefWndProc call.
'Supporting declares and functions:
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) ' Frees memory allocated by the shell
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 Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Function GetPIDLFromPathW(sPath As String) As Long
GetPIDLFromPathW = ILCreateFromPathW(StrPtr(sPath))
End Function
Public Function IID_IDataObject() As UUID
'0000010e-0000-0000-C000-000000000046
Static IID As UUID
If (IID.Data1 = 0) Then Call DEFINE_UUID(IID, &H10E, CInt(&H0), CInt(&H0), &HC0, &H0, &H0, &H0, &H0, &H0, &H0, &H46)
IID_IDataObject = IID
End Function
Public Function BHID_DataObject() As UUID
'{0xB8C0BD9F, 0xED24, 0x455C, 0x83,0xE6, 0xD5,0x39,0x0C,0x4F,0xE8,0xC4}
Static iid As UUID
If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &HB8C0BD9F, &HED24, &H455C, &H83, &HE6, &HD5, &H39, &HC, &H4F, &HE8, &HC4)
BHID_DataObject = iid
End Function
Public Sub DEFINE_UUID(Name As UUID, l As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
With Name
.Data1 = l
.Data2 = w1
.Data3 = w2
.Data4(0) = B0
.Data4(1) = b1
.Data4(2) = b2
.Data4(3) = B3
.Data4(4) = b4
.Data4(5) = b5
.Data4(6) = b6
.Data4(7) = b7
End With
End Sub
If you want to, you can specify your own drag image. For XP, see http://www.mvps.org/emorcillo/en/cod...ropimage.shtml
For Vista+, after you've created your IDataObject but before calling SHDoDragDrop, use this code:
Code:
Dim idsh As IDragSourceHelper2
Set idsh = New DragDropHelper
If hDragThumbnail Then
Dim sdi As SHDRAGIMAGE
sdi.hbmpDragImage = hBitmap
sdi.sizeDragImage.cx = width
sdi.sizeDragImage.cy = height
sdi.ptOffset.X = 24
sdi.ptOffset.Y = 24
sdi.crColorKey = CLR_NONE
idsh.SetFlags DSH_ALLOWDROPDESCRIPTIONTEXT
idsh.InitializeFromBitmap sdi, iData
End If
You can get the HBITMAP any number of ways. For example, if you wanted to get it from an image file, you could do:
Code:
Dim pFact As IShellItemImageFactory
oleexp.SHCreateItemFromParsingName StrPtr(PathToThumbnailFile), Nothing, IID_IShellItemImageFactory, pFact
pFact.GetImage width, height, SIIGBF_THUMBNAILONLY, hBitmap
UPDATE: Since I posted this project 5 years ago, I've found a more stable way to create the IDataObject. You shouldn't be using SHCreateDataObject or SHCreateFileDataObject.
Instead, once you have your array of pidls, use the function SHCreateShellItemArrayFromIDLists. That creates an IShellItemArray object, and once you have that object, you can use its method BindToHandler to create the IDataObject with ShellItemArray.BindToHandler 0&, BHID_DataObject, IID_IDataObject, iData. Note that olelib and OLEGuids do not contain IShellItemArray, so you'd need oleexp (and Vista+).
I've updated the attached project and code in this post to use this new method.
Last edited by fafalone; May 5th, 2020 at 11:03 PM.
Reason: New version!
Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro
Hi fafalone,
wow, brilliant stuff!!!
It works pretty much out of the box, but there is something missing compared to a drag initiated by Explorer. The following missing formats are expected by some drop targets:
CF_HDROP
FileName
FileNameW
FileContents
FileGroupDescriptorW
Especially FileContents is something I'm trying to get working for a long time without success. It has to be ISTREAM, but the VB DataObject nor the olelib IDataObject seem to accept ISTREAM. Any idea how to add that to IDataObject?
Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro
You might be able to add the format in... the IDataObject created should be a standard data object. But the difficulty in working with that is the whole reason for my post... it's extremely difficult to do anything, and most other things require implementing your own entire version, which despite very closely imitating an object-virtualization based implementation, I've never really been able to rework.
IDataObject.SetData isn't clear whether it would kill the other formats (although I believe it should append it, since MSDN says SHCreateDataObject supports added methods). I had tested some code for adding a CF_HDROP back when i was trying to roll my own, you could give this method a try:
Code:
Dim ido As oleexp.IDataObject
Dim pUnk As oleexp.IUnknown
Dim i As Long
Dim fmt As FORMATETC
Dim stg As STGMEDIUM
Dim objClsid As GUIDA
Dim s As String
Dim df As oleexp.DROPFILES
Dim hGlobal As Long
Dim lpGlobal As Long
Dim hr As Long
For i = 0 To 1
s = s & "C:\a" & i & ".txt" & vbNullChar
Next i
s = s & vbNullChar
hGlobal = GlobalAlloc(GHND, Len(df) + Len(s))
If hGlobal Then
lpGlobal = GlobalLock(hGlobal)
' Build DROPFILES structure in global memory.
df.pFiles = Len(df)
Call CopyMemory(ByVal lpGlobal, df, Len(df))
Call CopyMemory(ByVal (lpGlobal + Len(df)), ByVal s, Len(s))
Call GlobalUnlock(hGlobal)
fmt.cfFormat = CF_HDROP
fmt.dwAspect = DVASPECT_CONTENT
fmt.lIndex = -1
fmt.pDVTARGETDEVICE = 0
fmt.TYMED = TYMED_HGLOBAL
stg.TYMED = TYMED_HGLOBAL
stg.Data = lpGlobal
ido.SetData fmt, stg, 1
Also, the STGMEDIUM .data member is actually a union that should support IStream, you should be able to set it to ObjPtr(istream), with TYMED then being TYMED_ISTREAM; check MSDN for how other things should be set. Both the stdmedium and formatetc passed to .SetData must match on TYMED.
I'll try a few of these things out later on, bed time for me.
Edit: Very interesting comment on MSDN; there's an undocumented function called SHCreateFileDataObject that the member says creates it with both the shell id list (like in my code) and the CF_HDROP.
Try this declare, usage shouldn't be be different Public Declare Function SHCreateFileDataObject Lib "shell32" Alias "#740" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pDataInner As Any, ppDataObj As oleexp.IDataObject)
(untested, if that doesn't work try changing the 'ppDataObj As idataobject' to 'riid As UUID, ppv As Any')
Finally, be aware that the inner data object on both declares is supposed to be used for additional formats- if you could make a VB data object with the format you want (to bypass the lack of "As New IDataObject" possibility) and convert it to an IDataObject, you could set that parameter to ByVal ObjPtr(dataobjwithnewformat)
Last edited by fafalone; Nov 24th, 2016 at 05:39 PM.
Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro
Yes, I got it working!!!
Note that I could not use SHCreateFileDataObject -- it crashed the IDE (Win 8.1) with all signatures I tried.
So I added the missing formats one-by-one, and even the dreaded ISTREAM miraculously just worked this time. (I did not use the inner data object.)
Question: If I don't want the multiple paths support, what do I change in the code? (PS: Okay, probably pass the pidl of the parent folder for pidlDesk.)
Thanks very much, you helped me a lot me once again!
Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro
Cool, it's great when things actually work the way you expect them to.
Regarding SHCreateFileDataObject, you did remember to correct my omission of 'As Long' right? It doesn't crash, at least on Win7.
Code:
Public Declare Function SHCreateFileDataObject Lib "shell32" Alias "#740" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pDataInner As Any, ppDataObj As olelib.IDataObject) As Long
Call SHCreateFileDataObject(pidlDesk, cpidl, VarPtr(apidl(0)), ByVal 0&, iData)
I just had a chance to test it, and it works.
It creates the IDataObject with not only CF_HDROP, but also FileName and FileNameW. AND... it even shows custom drag and drop actions like 7-zip and WinRAR add, without any additional code!
My first thought on the crashing would be that you just passed 0 on the pDataInner argument, instead of ByVal 0&, which crashes the IDE on both functions.
Last edited by fafalone; May 21st, 2015 at 05:04 PM.
Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro
OK, now SHCreateFileDataObject works. And it actually creates all I need: CF_HDROP, FileName, FileContents, FileNameW, FileGroupDescriptorW. So this is the way, great!
BTW, it crashed because I copied the function declaration from your first post where the "As Long" was missing at the end.
Some other things:
- SHDoDragDrop totally takes over the mouse pointer. I cannot set any custom pointers via VB while the mouse is over my app. Correct? Or is there a way to use those DragImageBits in the DataObject to show the cool half-transparent drag image over my app? (I'm not using a ListView control, btw.)
- SHCreateDataObject appears to be Vista onwards, not XP onwards. (Not tested, just what the MSDN docs say.)
- You say "SHCreateFileDataObject ... it even shows custom drag and drop actions like 7-zip and WinRAR add, without any additional code!" Yes, but I get those actions also when using SHCreateDataObject.
Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro
Yeah sorry about the As Long thing, had been awake for a good 24-hours when I was writing that post. If SHCreateDataObject isn't available in XP, the good news is that SHCreateFileDataObject definitely is. I really wonder why MS has never supported it.
For custom pointers, you mean the actual mouse pointer or the drag image? Don't think there's any easy way to change the pointer, but the drag image can be changed. If you don't specify any hWnd in SHDoDragDrop, is it not showing the transparent blue box like in the main picture up top? If not, you can subclass the window for DI_GETDRAGIMAGE and return false according to a comment thread on MSDN, or custom draw it: https://social.msdn.microsoft.com/Fo...suidevelopment
Were you getting those extra menu items before adding in the extra formats, or just after?
And sorry one last question... what are you using to validate formats? If you're seeing FileGroupDescriptorW without manually adding it I've gotta figure out if it's just not being generated on my system or if ClipSpy just doesn't support it.
Last edited by fafalone; May 22nd, 2015 at 04:28 AM.
Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro
I get the transparent blue box, but not over my VB6 app. There is just the standard small mouse pointer (showing "+" for copy, etc). And when using SHDoDragDrop I cannot customize it using Screen.MousePointer = vbCustom. But thanks for the hint, I'll try the subclassing...
>Were you getting those extra menu items before adding in the extra formats, or just after?
Oh, sorry, forget what I said. I'm using a private method to show that drop context menu.
>what are you using to validate formats?
I have a small custom tool here for that. I can mail it to you if you like.
Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro
So I'm not seeing FileGroupDescriptorW with that tool either, but neither do I see it when I drag straight from Explorer. Weird.. is it important enough to obsess over?
And for the cursor, have you tried the SetCursor API?
Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro
FileGroupDescriptorW: That's weird indeed. Might depend on Windows version? (Win 8.1 here)
SetCursor API: Good idea, I tried it but the best I could achieve was an ultra-fast flicker between two mousepointers (mine and theirs). Well, not so important at the moment.
Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro
I've done a little work on drag images... here's how to use IDragSourceHelper (included in the 2015/6/11 oleexp) to create a custom drag image with a 32x32 file icon. Although this makes the description text disappear... on XP you're out of luck, but Vista+ lets us switch to IDragSourceHelper2 where you have the option to make it appear (i've been trying to customize that text via DropDescription as an hGloblal add without much luck).
With your already fully initialized IDataObject (just before SHDoDragDrop),
Code:
Dim idsh As IDragSourceHelper2
Set idsh = New DragDropHelper
If idsh Is Nothing Then
Debug.Print "Failed to create idropsourcehelper"
Exit Function
End If
Dim sdi As SHDRAGIMAGE
Call CreateDragImageForIDSH(sSelFullPath(0), sdi) 'note: change to your own file path source
If sdi.hbmpDragImage = 0 Then
Debug.Print "Failed to create drag image"
Exit Function
End If
idsh.SetFlags DSH_ALLOWDROPDESCRIPTIONTEXT 'will not be there if not set like this
idsh.InitializeFromBitmap sdi, iData
Call DeleteObject(sdi.hbmpDragImage)
And this example create drag image gets the icon... you can draw whatever you want here.. but from here on out I think it's manual drawing, I've been over tons of examples and none of them show how to create explorer's drag image
(original credit to Raymond Chen's Dragging A Shell Object post on Old New Thing, all I did was translate to VB)
Code:
Public Function CreateDragImageForIDSH(pszPath As String, psdi As SHDRAGIMAGE) As Long
Dim sfi As SHFILEINFO
Dim himl As Long
himl = SHGetFileInfoW(StrPtr(pszPath), 0, VarPtr(sfi), Len(sfi), SHGFI_SYSICONINDEX)
If himl Then 'if (himl) {
Dim cx As Long, cy As Long 'int cx, cy;
Call ImageList_GetIconSize(himl, cx, cy) 'ImageList_GetIconSize(himl, &cx, &cy);
psdi.sizeDragImage.cx = cx
psdi.sizeDragImage.cy = cy
psdi.ptOffset.X = cx
psdi.ptOffset.Y = cy
psdi.crColorKey = CLR_NONE
Dim hDC As Long
hDC = CreateCompatibleDC(0&)
If hDC Then 'if (hdc) {
psdi.hbmpDragImage = CreateBitmap(cx, cy, 1, 32, ByVal 0&) 'psdi->hbmpDragImage = CreateBitmap(cx, cy, 1, 32, NULL);
If psdi.hbmpDragImage Then 'if (psdi->hbmpDragImage) {
Dim hbmPrev As Long
'hbmPrev = SelectBitmap(hdc, psdi.hbmpDragImage)
hbmPrev = SelectObject(hDC, psdi.hbmpDragImage)
Call ImageList_Draw(himl, sfi.iIcon, hDC, 0, 0, ILD_NORMAL)
'SelectBitmap(hdc, hbmPrev);
Call SelectObject(hDC, hbmPrev)
End If
Call DeleteDC(hDC)
End If
End If
CreateDragImageForIDSH = psdi.hbmpDragImage
End Function
and finally some support (SHDRAGIMAGE is also in new typelib)
Code:
Public Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Public Declare Function ImageList_GetIconSize Lib "comctl32.dll" (ByVal himl As Long, lpcx As Long, lpcy As Long) As Boolean
Public Declare Function ImageList_Draw Lib "comctl32.dll" (ByVal himl As Long, ByVal i As Long, ByVal hdcDst As Long, ByVal X As Long, ByVal Y As Long, ByVal fStyle As IL_DrawStyle) As Boolean
Private Const CLR_NONE = &HFFFFFFFF
Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function SHGetFileInfoW Lib "shell32" (ByVal pszPath As Long, ByVal dwFileAttributes As Long, ByVal psfi As Long, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Public Type SHFILEINFO ' shfi
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Public Const SHGFI_SYSICONINDEX = &H4000
Public Sub DEFINE_UUID(Name As UUID, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
With Name
.Data1 = L
.Data2 = w1
.Data3 = w2
.Data4(0) = B0
.Data4(1) = b1
.Data4(2) = b2
.Data4(3) = B3
.Data4(4) = b4
.Data4(5) = b5
.Data4(6) = b6
.Data4(7) = b7
End With
End Sub
Public Function IID_IDragSourceHelper() As UUID
'{de5bf786-477a-11d2-839d-00c04fd918d0}
Static iid As UUID
If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &HDE5BF786, CInt(&H477A), CInt(&H11D2), &H83, &H9D, &H0, &HC0, &H4F, &HD9, &H18, &HD0)
IID_IDragSourceHelper = iid
End Function
Public Function IID_IDragSourceHelper2() As UUID
'{83E07D0D-0C5F-4163-BF1A-60B274051E40}"
Static iid As UUID
If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H83E07D0D, CInt(&HC5F), CInt(&H4163), &HBF, &H1A, &H60, &HB2, &H74, &H5, &H1E, &H40)
IID_IDragSourceHelper2 = iid
End Function
Last edited by fafalone; Jun 11th, 2015 at 10:48 AM.