 Dragging from Explorer |
 Dragging from Firefox |
So as we all know, the drag cursor for a VB drop target is a hideous relic of the Windows 3.1 days. No more! Ever since XP, there has been an interface called IDropTargetHelper that automatically shows the proper drag image. And not just for Explorer file drops; the drag image you see in any modern program will now also appear on your VB6 drop target. And more good news, it's only a tiny bit more complicated than using the normal OLEDragDrop features (this method completely replaces the native OLE DnD stuff and controls should be 'None' for OLEDropMode- the IDropTarget class has DragEnter, DragOver, DragLeave, and Drop events if you need them).
Requirements
-Windows XP or higher
-oleexp.tlb (any version; no new release is associated with this project and the interfaces used date back to the 1.x versions)
How It Works
-First, a class module that implements IDropTarget and contains an instance of IDropTargetHelper needs to be created
-The only tricky thing is getting the file list from the IDataObject; but the sample class handles this and just passes a file list back.
-Then, any control can call the RegisterDragDrop API to become a target supporting the new images!
Note that while the example just accepts file drops with the standard CF_HDROP format, you have the full data object passed from the source of the drag, and could retrieve any format it contains (there's tons of clipboard formats; text, html, images, etc).
Note on Unicode support: All the code is designed to support Unicode, but the file names in the sample project are displayed in a regular VB textbox which cannot show extended characters-- but the file names returned are in Unicode and if displayed in a Unicode-enabled control will be rendered correctly.
Code
cDropTarget
Code:
Option Explicit
Private Declare Function DragQueryFileW Lib "shell32.dll" (ByVal hDrop As Long, ByVal iFile As Long, Optional ByVal lpszFile As Long, Optional ByVal cch As Long) As Long
Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long
Private Declare Function CoCreateInstance Lib "ole32" (rclsid As Any, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, riid As Any, pvarResult As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszGuid As Long, pGuid As Any) As Long
'IDropTargetHelper is what lets us show the drag image
Private pDTH As IDropTargetHelper
Private Const CLSID_DragDropHelper = "{4657278A-411B-11D2-839A-00C04FD918D0}"
Private Const IID_IDropTarget = "{4657278B-411B-11D2-839A-00C04FD918D0}"
Implements IDropTarget
Private Sub Class_Initialize()
Dim dhiid As UUID
Dim dthiid As UUID
Call CLSIDFromString(StrPtr(CLSID_DragDropHelper), dhiid)
Call CLSIDFromString(StrPtr(IID_IDropTarget), dthiid)
Call CoCreateInstance(dhiid, 0&, CLSCTX_INPROC_SERVER, dthiid, pDTH)
End Sub
Private Sub IDropTarget_DragEnter(ByVal pDataObj As oleexp3.IDataObject, ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As oleexp3.DROPEFFECTS)
Debug.Print "DragEnter"
Dim pt As oleexp3.POINT
pt.x = ptX
pt.y = ptY
pDTH.DragEnter Form1.Picture1.hWnd, pDataObj, pt, pdwEffect
End Sub
Private Sub IDropTarget_DragLeave()
Debug.Print "DragLeave"
pDTH.DragLeave
End Sub
Private Sub IDropTarget_DragOver(ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As oleexp3.DROPEFFECTS)
Debug.Print "DragOver"
Dim pt As oleexp3.POINT
pt.x = ptX
pt.y = ptY
pDTH.DragOver pt, pdwEffect
'Notice that the text shows 'Move' in the caption; you can change pdwEffect to something else
'pdwEffect = DROPEFFECT_COPY
'pdwEffect = DROPEFFECT_NONE 'this shows that a drop is not allowed, and the drop event won't fire
End Sub
Private Sub IDropTarget_Drop(ByVal pDataObj As oleexp3.IDataObject, ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As oleexp3.DROPEFFECTS)
Debug.Print "Drop"
Dim idx As Long
Dim pt As oleexp3.POINT
pt.x = ptX
pt.y = ptY
pDTH.Drop pDataObj, pt, pdwEffect
'For this project, we're just going to accept the files and pass back what
'operation we did with them. But to add more functionality, you can look
'at grfKeyState; that will tell you if ctrl is being held so you can move,
'or if the right mouse button is down and you should show a menu of options
Dim fmt As FORMATETC
fmt.cfFormat = CF_HDROP
fmt.TYMED = TYMED_HGLOBAL
fmt.dwAspect = DVASPECT_CONTENT
fmt.lindex = -1
Dim stg As STGMEDIUM
If pDataObj.QueryGetData(fmt) = S_OK Then
pDataObj.GetData fmt, stg
Dim nFiles As Long, sFiles() As String
Dim i As Long
Dim sBuffer As String
nFiles = DragQueryFileW(stg.Data, &HFFFFFFFF, 0, 0)
ReDim sFiles(nFiles - 1)
For i = 0 To nFiles - 1
SysReAllocStringLen VarPtr(sBuffer), , DragQueryFileW(stg.Data, i)
DragQueryFileW stg.Data, i, StrPtr(sBuffer), Len(sBuffer) + 1&
sFiles(i) = sBuffer
Next
Else
Debug.Print "failed querygetdata"
End If
pdwEffect = Form1.DropFiles(sFiles, grfKeyState)
End SubCode:
Option Explicit
Private Declare Function RegisterDragDrop Lib "ole32" _
(ByVal hWnd As Long, ByVal DropTarget As IDropTarget) As Long
Private Declare Function RevokeDragDrop Lib "ole32" (ByVal hWnd As Long) As Long
Private cIDT As cDropTarget
Public Function DropFiles(sFiles() As String, KeyState As Long) As DROPEFFECTS
'Do whatever with the files
Text1.Text = ""
Text1.Text = Join(sFiles, vbCrLf)
DropFiles = DROPEFFECT_NONE 'We didn't do anything with the dropped files here,
'but if you do move/copy/link them, report that back
End Function
Private Sub Form_Load()
Set cIDT = New cDropTarget
Call RegisterDragDrop(Picture1.hWnd, cIDT)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call RevokeDragDrop(Picture1.hWnd)
End SubNote that if you combine this method with a control that's a drag source for files using my SHCreateDataObject/SHDoDragDrop method, you will now see the Explorer icon right on the control you're dragging from, and the filetype icon will now show up. No additional coding required. At some point in the future I'll release a sample combining them, but in the mean time they are completely compatible if someone else wants to. (I have tested and confirmed this, it's just ripping out the file listview that has dozens of other features and thousands of lines of code associated with it-- testing is easier on a fully complete file view-- isn't practical)
------------------------------------------
Project updated: Forgot DragDropHelper coclass can't be used on XP; updated to use it by CLSID with CoCreateInstance. Code for Class_Initialize updated in sample project and above in this post.