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

[fafalone]

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 (project updated to reference oleexp 4.0 or higher)

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.
-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

Option Explicit
'---------------------------------------------------------------------
'cDropTarget 0.5
'Provides a modern drop target that shows drag images automatically,
'with generic events to hand off processing to the object
'Usage:
'-Create new instance of this class for each drop target
'-Call the .Attach function
'-Handle events
'Detach is automatically called when the class terminates, but you
'can also call it at any time to turn off drop target functionality.
'
'Update 2024 May 14:
'  -Added optional argument bTakeOverExisting, defaulting to True,
'   to unregister drag drop if another control has already registered,
'   and use this class instead. Usefor for windowless UserControls,
'   which register the entire window even when dragdrop is disabled.
'
'Update 2024 May 07:
'  -Bug fix for TotalCommander or other drag sources that may cause
'   an error in the DragDropHelper. You won't get the drag image in
'   these cases, but will still likely be able to recover the file
'   names, as is the case for TotalCommander.
'
'(c) 2016-2024 by fafalone
'---------------------------------------------------------------------


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
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

'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}"

Private m_hWnd As Long

Public Event DragEnter(pDataObj As oleexp.IDataObject, grfKeyState As Long, ptx As Long, pty As Long, pdwEffect As DROPEFFECTS)
Public Event DragOver(grfKeyState As Long, ptx As Long, pty As Long, pdwEffect As DROPEFFECTS)
Public Event Drop(pDataObj As oleexp.IDataObject, grfKeyState As Long, ptx As Long, pty As Long, pdwEffect As DROPEFFECTS)
Public Event DragLeave()

Implements IDropTarget

Public Function Attach(hWnd As Long, Optional bTakeOverExisting As Boolean = True) As Long
    'after configuring settings, call this to attach to an hWnd
    m_hWnd = hWnd
    Attach = RegisterDragDrop(hWnd, Me)
    If (Attach = DRAGDROP_E_ALREADYREGISTERED) And (bTakeOverExisting = True) Then
        RevokeDragDrop hWnd
        Attach = RegisterDragDrop(hWnd, Me)
    End If
End Function
Public Function Detach() As Long
    'There's an appcrash if revoke is called on an unregistered window
    If RegisterDragDrop(m_hWnd, Me) = DRAGDROP_E_ALREADYREGISTERED Then
        Detach = RevokeDragDrop(m_hWnd)
    End If
End Function

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 Class_Terminate()
    Call Detach
    Set pDTH = Nothing
End Sub

Private Sub IDropTarget_DragEnter(ByVal pDataObj As oleexp.IDataObject, ByVal grfKeyState As Long, ByVal ptx As Long, ByVal pty As Long, pdwEffect As oleexp.DROPEFFECTS)
    '   Debug.Print "DragEnter"
    
    Dim pt As oleexp.POINT
    pt.x = ptx
    pt.y = pty
    
    On Error Resume Next
    pDTH.DragEnter m_hWnd, pDataObj, pt, pdwEffect
    On Error GoTo 0
    
    RaiseEvent DragEnter(pDataObj, grfKeyState, ptx, pty, pdwEffect)
    
    
End Sub

Private Sub IDropTarget_DragLeave()
    'Debug.Print "DragLeave"
    
    pDTH.DragLeave
    RaiseEvent DragLeave
End Sub

Private Sub IDropTarget_DragOver(ByVal grfKeyState As Long, ByVal ptx As Long, ByVal pty As Long, pdwEffect As oleexp.DROPEFFECTS)
    '    Debug.Print "DragOver"
    
    Dim pt As oleexp.POINT
    pt.x = ptx
    pt.y = pty
    
    pDTH.DragOver pt, pdwEffect
    
    RaiseEvent DragOver(grfKeyState, ptx, pty, 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 oleexp.IDataObject, ByVal grfKeyState As Long, ByVal ptx As Long, ByVal pty As Long, pdwEffect As oleexp.DROPEFFECTS)
    'Debug.Print "Drop"
    Dim pt As oleexp.POINT
    pt.x = ptx
    pt.y = pty
    On Error Resume Next
    pDTH.Drop pDataObj, pt, pdwEffect
    On Error GoTo 0
    RaiseEvent Drop(pDataObj, grfKeyState, ptx, pty, pdwEffect)
End Sub

Sample Form

Option Explicit
'IDropTarget Example by fafalone
'This takes advantage of the new drop features that will show the proper drag icon
'while being dragged over. If you dragged FROM such a window, it would also show the
'same drag icon that Explorer would show if you combined this with the technique
'from my SHDoDragDrop example.
'At some point in the future I'll release a project showing them combined, but
'for learning and simplicity here we'll just show dropping

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 WithEvents cIDT As cDropTarget

Private Sub cIDT_Drop(pDataObj As oleexp.IDataObject, grfKeyState As Long, ptx As Long, pty As Long, pdwEffect As oleexp.DROPEFFECTS)
 '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
 
 'You're not limited to just CF_HDROP either, you could process the data object
 'for any clipboard format you want
 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
Text1.Text = ""
Text1.Text = Join(sFiles, vbCrLf)
pdwEffect = DROPEFFECT_NONE 'We didn't do anything with the dropped files here,
                            'but if you do move/copy/link them, report that back
End Sub

Private Sub Form_Load()
Set cIDT = New cDropTarget
cIDT.Attach Me.hwnd
End Sub

Dragging FROM controls
Note 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.

Project updated 2 (03 Aug 2016): - cDropTarget.cls has been made more portable and slightly easier to use. No code inside the class needs to change to drop it into a new project. Simply create a new instance withevents, use .Attach to bind it to an hWnd, and then it raises events for each of the drop methods and passes all the parameters back to the form.

Project updated 3 (24 Nov 2016): - Updated to reference oleexp.tlb v4.0 or higher

Project updated 4 (07 May 2024): - Fix for Invalid FORMATETC and other errors with the DragDropHelper object.

Project updated 5 (14 May 2024): - Added option to Attach, bTakeOverExisting, to unregister and reregister windows that were already registered-- such as windowless UserControls even without dragdrop.

---

64bit Compatible twinBASIC version now available!

This project has a 64bit compatible version for twinBASIC that demonstrates defining interfaces in tB and dealing with some complications arising in 64bit with the unusual ByVal POINT arguments of IDropTarget.

Available on GitHub: https://github.com/fafalone/DragDropDemo