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

Attachment 194389 Dragging from Explorer

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

Code:

---

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

Code:

---

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

Additional Ideas

IShellItem access for Vista+
The method included in the sample project to get the names of the dropped files is designed to retain XP compatibility. If you're using Vista+, there's a better way to deal with the dropped items that directly gives you IShellItems to work with.

Code:

---


Public Declare Function SHCreateShellItemArrayFromDataObject Lib "shell32" (ByVal pdo As oleexp.IDataObject, riid As UUID, ppv As Any) As Long
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)
  Dim pt As oleexp.POINT
  pt.X = ptX
  pt.Y = ptY
 
 LVDH.Drop pDataObj, pt, pdwEffect
'[...] Code to check if CF_HDROP is available omitted here but still needed
    Dim psia As IShellItemArray
    Dim piesi As IEnumShellItems
    Dim pItem As IShellItem
    Dim lpFile As Long
    Dim pcl As Long
    Call SHCreateShellItemArrayFromDataObject(pDataObj, IID_IShellItemArray, psia)
    If (psia Is Nothing) = False Then
        psia.EnumItems piesi
        Do While (piesi.Next(1, pItem, pcl) = NOERROR)
            pItem.GetDisplayName SIGDN_FILESYSPATH, lpFile
            Debug.Print "Dropfile " & BStrFromLPWStr(lpFile)
        Loop
    End If
End Sub

Public Function BStrFromLPWStr(lpWStr As Long, Optional ByVal CleanupLPWStr As Boolean = True) As String
SysReAllocString VarPtr(BStrFromLPWStr), lpWStr
If CleanupLPWStr Then CoTaskMemFree lpWStr
End Function

---

Drop menu
Showing the drop menu turned out to be different than I first thought. The Drop method fires after you release the mouse button, so grfKeyState doesn't reflect which button did the dropping. Instead, you have to look at the grfKeyState in the DragEnter event, and set a flag.

Code:

---

Private bShowMenu As Boolean
Private Const MK_RBUTTON = 2&
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)
'[...]
    If (grfKeyState And MK_RBUTTON) = MK_RBUTTON Then
        bShowMenu = True
    Else
        bShowMenu = False
    End If

  LVDH.DragEnter hLVS, pDataObj, pt, pdwEffect
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)
Dim pt As oleexp.POINT
pt.X = ptX
pt.Y = ptY
 If bShowMenu Then
    Dim hMenu As Long, idCmd As Long
    hMenu = CreatePopupMenu()
    AppendMenu hMenu, MF_STRING, 100, "Copy here"
    AppendMenu hMenu, MF_STRING, 101, "Move here"
    AppendMenu hMenu, MF_STRING, 102, "Create shortcut here"
    AppendMenu hMenu, MF_SEPARATOR Or MF_DISABLED, 0&, ByVal 0&
    AppendMenu hMenu, MF_STRING, 103, "Cancel"
    idCmd = TrackPopupMenu(hMenu, TPM_LEFTBUTTON Or TPM_RIGHTBUTTON Or TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_HORIZONTAL Or TPM_RETURNCMD, ptX, ptY, 0, Form1.Picture1.hWnd, 0) '<- REPLACE hLVS WITH THE HWND OF THE CONTROL ITS FOR
End If
 LVDH.Drop pDataObj, pt, pdwEffect

'Adjust subsequent code to do the operation indicated by idCmd
'[...]
End Sub

---

Multiple drop targets
The original sample project didn't take this into consideration and hardcoded an hWnd, which won't work for more than 1 control. So if you wanted multiple drop targets, you'd add a property to set the hWnd:

Code:

---

Private m_hWnd As Long

Public Property Let DropHWND(hWnd As Long)
m_hWnd = hWnd
End Property
Public Property Get DropHWND() As Long
DropHWND = m_hWnd
End Property

---

Then when you create the class (Set cDT = New cDropTarget), you follow it with cDT.DropHWND = Picture1.hWnd or whatever control you're setting it up for.

For even more examples to expand on this project, jump down to Post #11

Hello
running on XP sp3 I get Run-Time error 430

Code:

---

Set pDTH = New DragDropHelper

---

Sorry forgot to create that the old fashioned way. The DragDropHelper coclass on Vista+ contains IDragSourceHelper2, and is defined as such in the tlb, causing the error.

The project has been updated to create IDropTargetHelper without the DragDropHelper coclass from the TLB.

Code:

---

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 Const CLSID_DragDropHelper = "{4657278A-411B-11D2-839A-00C04FD918D0}"
Private Const IID_IDropTarget = "{4657278B-411B-11D2-839A-00C04FD918D0}"

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

---

Thank you for updating your project. I was just about ready to post the same error Nanni posted.

I added to the sub

Code:

---

Public Function DropFiles(sFiles() As String, KeyState As Long) As DROPEFFECTS
'Do whatever with the files
Text1.Text = ""
Text1.Text = Join(sFiles, vbCrLf)
 
Set Picture1.Picture = LoadPicture(sFiles(0))

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

---

which puts the image in picture1.

What do I return as DROPEFFECTS? It shouldn't be DROPEFFECT_NONE I think

Are you ever going to get rid of that image of the little box with the curved arrow in the lower corner? I notice when I drag from Windows Explorer ListView pane it only shows the default arrow as it drags over the TreeView pane but as it drags over Picture1 it changes to show the little box in addition to the default arrow

Does your Picturebox have its OLEDropMode set to something other than none? Only reason I can think of why it would draw the VB arrow on top of the normal drag image /cursor. Also drag it on to other modern programs and see if it appears there too, if it does there won't be anything you can do.

The DROPEFFECT refers to move, copy, and link... if you didn't do any of those actions, you don't have a drop effect to report.

Quote:

---

Originally Posted by fafalone

Does your Picturebox have its OLEDropMode set to something other than none? Only reason I can think of why it would draw the VB arrow on top of the normal drag image /cursor.

---

It's the picturebox from your sample (DropTarget.zip) and it has OLEDropMode = 0 (None)

Quote:

---

Originally Posted by fafalone

Also drag it on to other modern programs and see if it appears there too, if it does there won't be anything you can do.

---

Any drag from Windows Explorer to any other application has the small box with the curved arrow in the lower corner and the default arrow but no image of the icon + file name. Only on your sample project do I get the small box with the curved arrow in the lower corner and the default arrow plus the icon and filename

Quote:

---

Originally Posted by fafalone

The DROPEFFECT refers to move, copy, and link... if you didn't do any of those actions, you don't have a drop effect to report.

---

I did a copy. So what is the correct DROPEFFECTS return? DROPEFFECT_????

I fired up XP with a VM, and the drag image and cursor shown in the Picturebox is 100% identical to the one shown in Explorer, with the exception that the default effect is changed to link... so it shows the shortcut arrow overlay instead of the little plus sign that Copy shows. If that's actually what you're talking about, you can change the default effect by setting pdwEffect = DROPEFFECT_COPY in DragEnter and DragOver (before passing it on to pDTH); then it will show the copy + sign instead of the shortcut arrow.
This is what it looks like in XP after changing the default effect to Copy:
http://i.imgur.com/3fiao0f.jpg
Is that what you're trying for?

And yes, if you copied the file to a new location you should return DROPEFFECT_COPY.

Quote:

---

Originally Posted by fafalone

I fired up XP with a VM, and the drag image and cursor shown in the Picturebox is 100% identical to the one shown in Explorer, with the exception that the default effect is changed to link... so it shows the shortcut arrow overlay instead of the little plus sign that Copy shows. If that's actually what you're talking about, you can change the default effect by setting pdwEffect = DROPEFFECT_COPY in DragEnter and DragOver (before passing it on to pDTH); then it will show the copy + sign instead of the shortcut arrow.
This is what it looks like in XP after changing the default effect to Copy:
http://www.vbforums.com/images/ieimages/2015/10/1.jpg
Is that what you're trying for?

---

Just the opposite. I would like to have it the same way Explorer has it when it is dragging over the TreeView pane of Explorer; that is, only the file icon + file name and the default arrow (no little boxes with + sign)

If you change the default effect to DROPEFFECT_MOVE, it looks like this:
http://i.imgur.com/XmLs6xN.jpg

That tiny box seems to be the only difference; but there's no way to get rid of that. If that's really a deal breaker you're just going to have to draw the image yourself. DragEnter provides access to the IDataObject, so you can get the list of files there.

Edit: BTW, loading the contents of a dropped file into a picturebox or textbox, or into memory, is not copying.

Changing the Drop Description
http://i.imgur.com/NMEgHSN.jpg

As an enhancement to this project, I've worked out how to change the drop description. Note that while this would also work with the data object produced via SHCreateFileDataObject when dragging FROM your control, it would be changed by any drop target that sets it, and most do.

First, add a module level variable to cDropTarget.cls:
Private mDataObj As IDataObject

This will store a reference to the data object being dropped, since we'll need to clear our custom tip on IDropTarget_DragLeave(), which doesn't provide a pDataObj argument.

Second, change the tip on IDropTarget_DragEnter and store that reference, immediately after calling the helper:

Code:

---

  pDTH.DragEnter m_hWnd, pDataObj, pt, pdwEffect
 
  IDO_AddDropDesc pDataObj, DROPIMAGE_MOVE, "Frob with %1", "MyApp"
  Set mDataObj = pDataObj

---

The two different arguments allow the 2 different colors of the text. %1 is replaced with the second string.

Third, on IDropTarget_DragLeave(), clear the tip and release the reference we stored, again immediately after calling the helper:

Code:

---

    pDTH.DragLeave
    IDO_AddDropDesc mDataObj, DROPIMAGE_INVALID, "", ""
    Set mDataObj = Nothing

---

Last but not least, here's what's needed for the IDO_AddDropDesc sub:

Code:

---

Private Const CFSTR_DROPDESCRIPTION As String = "DropDescription"
Private Type DROPDESCRIPTION
    type As DropImageType
    szMessage(MAX_PATH - 1) As Integer
    szInsert(MAX_PATH - 1) As Integer
End Type
Private Enum DROPIMAGETYPE
  DROPIMAGE_INVALID = -1
  DROPIMAGE_NONE = 0
  DROPIMAGE_COPY = 1 'DROPEFFECT_COPY
  DROPIMAGE_MOVE = 2 'DROPEFFECT_MOVE
  DROPIMAGE_LINK = 4 'DROPEFFECT_LINK
  DROPIMAGE_LABEL = 6
  DROPIMAGE_WARNING = 7
  DROPIMAGE_NOIMAGE = 8 'Win 7 and above only
End Enum

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Private 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 lpFmt 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
   
    lpFmt = RegisterClipboardFormatW(StrPtr(CFSTR_DROPDESCRIPTION))
   
    fmt.cfFormat = lpFmt
    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(MAX_PATH - 1)
If Len(sz) > MAX_PATH Then sz = Left$(sz, MAX_PATH)
For i = 1 To Len(sz)
    iOut(i - 1) = AscW(Mid(sz, i, 1))
Next i

End Sub

---

Taking it even further
Let's say you're displaying a list of file and folders, and you want to be able to drop into a specific item on your listview/treeview:
http://i.imgur.com/H78YeNi.jpg
Obviously there's a lot of variation with what you might want to set the labels to, but the general idea is:

Code:

---

Private Sub IDropTarget_DragOver(ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As oleexp.DROPEFFECTS)
  Dim pt As oleexp.POINT
  pt.X = ptX
  pt.Y = ptY

  Dim lPrevItemIndex As Long
 
    pDTH.DragOver pt, pdwEffect
    lPrevItemIndex = lItemIndex
    lItemIndex = LVDragOverFolder(m_hWnd, pt, lItemIndex)
    If (lItemIndex >= 0) Then
        mDragOver = glbRes(GetLVItemlParam(m_hWnd, lItemIndex)).sName
    Else
        mDragOver = "MyApp"
    End If
    If (lItemIndex <> lPrevItemIndex) Then 'make sure we only do this once for each item dragover, otherwise it will
                                          'be called several times per second and muck things up
        IDO_AddDropDesc mDataObj, DROPIMAGE_MOVE, "Frob with %1", mDragOver
    End If
End Sub

---

I store the files of my ListView in glbRes (along with properties like bDirectory for below), then when I add them to my ListView I tag the ListItem with their position in the glbRes array (you can store this number in ListItem.Tag if you're using a regular ListView).

And it doesn't even have to be files and folders; this method is readily adaptable to highlight a listview item on any criteria you want.

The LVDragOverFolder, which selects/deselects folders during DragOver, looks like this (as this is sufficiently advanced I'm not going to spend the time cobbling together the standard API declares and ListView defs)::

Code:

---

Public Function LVDragOverFolder(hWnd As Long, ppt As oleexp.POINT, lPrevItem As Long) As Long
'called in response to the DragOver event, checks if it's a folder being dragged
'over, and if so selects it and returns the full path
'return -1 if not on an item that's a drop target (here, that means a folder)
'otherwise, return the item index

Dim LVHTI As LVHITTESTINFO
Dim lpOld As Long

Call ScreenToClient(hWnd, ppt)
LVHTI.pt.X = ppt.X
LVHTI.pt.Y = ppt.Y

ListView_HitTest hWnd, LVHTI
''Debug.Print "htflags/" & ppt.X & "=" & LVHTI.Flags
If (LVHTI.Flags And LVHT_ONITEM) Then
    Dim lp As Long
    lp = GetLVItemlParam(hWnd, LVHTI.iItem)
    'Debug.Print "dragover " & glbRes(lp).sName
    If LVHTI.iItem <> lPrevItem Then
        If glbRes(lp).bDirectory Then
            If (ListView_GetItemState(hWnd, LVHTI.iItem, LVIS_FOCUSED) = 0) Then
                ListView_SetItemState hWnd, LVHTI.iItem, LVIS_FOCUSED Or LVIS_SELECTED, LVIS_FOCUSED Or LVIS_SELECTED
            End If
            LVDragOverFolder = LVHTI.iItem
        Else
            LVDragOverFolder = -1
        End If
        If (lPrevItem <> -1) And (lPrevItem <> LVHTI.iItem) Then
            If ListView_GetItemState(hWnd, lPrevItem, LVIS_SELECTED) Then
                lpOld = GetLVItemlParam(hWnd, lPrevItem)
                ListView_SetItemState hWnd, lPrevItem, 0&, LVIS_FOCUSED
                ListView_SetItemState hWnd, lPrevItem, 0&, LVIS_SELECTED
            End If
        End If
    Else
        'same item
        LVDragOverFolder = LVHTI.iItem
    End If
Else
    'not on item; if there was a previous one, clear it
    If (lPrevItem <> -1) Then
            If ListView_GetItemState(hWnd, lPrevItem, LVIS_SELECTED) Then
                lpOld = GetLVItemlParam(hWnd, lPrevItem)
                ListView_SetItemState hWnd, lPrevItem, 0&, LVIS_FOCUSED
                ListView_SetItemState hWnd, lPrevItem, 0&, LVIS_SELECTED
            End If
    End If
    LVDragOverFolder = -1
End If
       
End Function

Public Function GetLVItemlParam(hwndLV As Long, iItem As Long) As Long
  Dim lvi As LVITEM
 
  lvi.mask = LVIF_PARAM
  lvi.iItem = iItem
  If ListView_GetItem(hwndLV, lvi) Then
    GetLVItemlParam = lvi.lParam
  End If

End Function
Public Function ListView_GetItemState(hwndLV As Long, i As Long, mask As LVITEM_state) As Long  ' LVITEM_state
  ListView_GetItemState = SendMessage(hwndLV, LVM_GETITEMSTATE, ByVal i, ByVal mask)
End Function
Public Function ListView_SetItemState(hwndLV As Long, i As Long, State As LVITEM_state, mask As LVITEM_state) As Boolean
  Dim lvi As LVITEM
  lvi.State = State
  lvi.StateMask = mask
  ListView_SetItemState = SendMessage(hwndLV, LVM_SETITEMSTATE, ByVal i, lvi)
End Function
Public Function ListView_HitTest(hwndLV As Long, pInfo As LVHITTESTINFO) As Long
  ListView_HitTest = SendMessage(hwndLV, LVM_HITTEST, 0, pInfo)
End Function

---

With these last two things, finally VB6 apps can have every last bit of the fancy drag-and-drop UI of modern Windows.

Edit: One more thing that I didn't even think was possible:
Show the drop context menu of a folder
If you're displaying ListView with folders, it's actually possible to show the context menu of that folder, instead of using the custom menu option from post #2. This also works with drags originating from your control via SHDoDragDrop.
http://i.imgur.com/Ff90IPD.jpg

As shown in the picture, the advantage of this method is that it loads any 3rd-party menu entries that were added to Explorer.
There is another huge advantage to this: Explorer will handle the selected operation itself, 3rd party options included. It will copy the file to that folder, or add it to a RAR in that folder, all by itself.
For the purposes of the below code, the previous example of locating the folder during DragOver should store the target folder in sFolder. This replaces the bShowMenu If-block in Post #2

Code:

---

If (bShowMenu = True) And (sFolder <> "") Then 'if sfolder is empty, the drag image will get stuck and no menu will pop
    Dim pDT As IDropTarget
    Dim psf As IShellFolder
    Dim pidl() As Long
    ReDim pidl(0)
    pidl(0) = ILCreateFromPathW(StrPtr(sFolder))
    isfDesktop.GetUIObjectOf 0&, 1, pidl(0), IID_IDropTarget, 0&, pDT
    If (pDT Is Nothing) = False Then
        pDT.DragEnter pDataObj, MK_RBUTTON, ptX, ptY, pdwEffect 'pdwEffect has no effect here; Explorer chooses the default
        pDT.Drop pDataObj, MK_RBUTTON, ptX, ptY, DROPEFFECT_MOVE Or DROPEFFECT_COPY Or DROPEFFECT_LINK 'allowed effects.. if it's not here it won't appear on the menu
        pDTH.Drop pDataObj, pt, pdwEffect
        Exit Sub
    Else
        Debug.Print "no pDT"
    End If
End If

---

Supporting code:
(some standard declares left out)

Code:

---

Private Declare Function SHGetDesktopFolder Lib "shell32" (ppshf As IShellFolder) As Long ' Retrieves the IShellFolder interface for the desktop folder.


Public Function isfDesktop() As IShellFolder
  Static isf As IShellFolder
  If (isf Is Nothing) Then Call SHGetDesktopFolder(isf)
  Set isfDesktop = isf
End Function
Public Function IID_IDropTarget() As UUID
'{00000122-0000-0000-C000-000000000046}
Static iid As UUID
 If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H122, CInt(&H0), CInt(&H0), &HC0, &H0, &H0, &H0, &H0, &H0, &H0, &H46)
 IID_IDropTarget = iid
End Function

---

(minor bug: for some reason, the context menu entry for 7-zip that I normally see did not appear; CreateViewObject instead of GetUIObject was the same, as was using an IShellFolder for the immediate parent and a relative pidl)

Hi faf,

Don't know how you got this to work:

Code:

---

For i = 0 To UBound(iTmp2)
    tDD.szInsert(i) = iTmp2(i - 4)
Next i

---

i will always be less than zero first time in and 'subscript out of range'

Sorry that's a typo from when I corrected an offset bug. Previously the upper bound was being set to 255 instead of 259 (MAX_PATH - 1), and instead of causing a problem with the last 4 characters, it caused the first 4 to be ignored. Before I identified that as the issue I was copying the string starting at 4 instead of 0.

It should just be

Code:

---

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

---

OK, i had already corrected it in my code to what you posted above but, alas, it doesn't work on XP SP3 :(

Yeah XP doesn't have a drop description to change. It's not showing "copy to blah" to begin with because there's just no code there that renders the tip.

All the other things should work though.

Ok, that's fair enough, then. Been playing around a bit more with this and it's not obvious to me how to handle DataObjects of types vbCFDIB and vbCFText. Have searched MSDN but remain un-enlightened. Clearly something to do with manipulating STGMEDIUM but not certain how.

Anything you can assist with, please?

Well... this looks fun.

In the case of CF_DIB, an hDIB is stored as hGlobal. GlobalLock on that hGlobal will produce a pointer to a BITMAPINFOHEADER structure. So that should produce all the info required to draw it to an hDC. I'll need a little time to work out the details on that.

CF_TEXT is easier; it's also stored as hGlobal, but it's far easier to turn a pointer to a string into a VB-usable string:

Code:

---

  Dim tSTG As STGMEDIUM
  Dim tFMT As FORMATETC
  tFMT.cfFormat = CF_TEXT
  tFMT.dwAspect = DVASPECT_CONTENT
  tFMT.TYMED = TYMED_HGLOBAL
  tFMT.lIndex = -1
 
  If pDataObj.QueryGetData(tFMT) = S_OK Then
    Debug.Print "got text drop"
    pDataObj.GetData tFMT, tSTG
    Dim lpText As Long
    lpText = GlobalLock(tSTG.Data)
    Debug.Print GetStrFromPtrA(lpText)
    Call GlobalUnlock(tSTG.Data)
    ReleaseStgMedium tSTG
    Exit Sub
  Else
    Debug.Print "failed cf_text"
  End If

---

And for Unicode support:

Code:

---

  Dim tSTG As STGMEDIUM
  Dim tFMT As FORMATETC
  tFMT.cfFormat = CF_UNICODETEXT
  tFMT.dwAspect = DVASPECT_CONTENT
  tFMT.TYMED = TYMED_HGLOBAL
  tFMT.lIndex = -1
 
  If pDataObj.QueryGetData(tFMT) = S_OK Then
    Debug.Print "got unicode text drop"
    pDataObj.GetData tFMT, tSTG
    Dim lpText As Long
    lpText = GlobalLock(tSTG.Data)
    Debug.Print LPWSTRtoStr(lpText, False)
    Call GlobalUnlock(tSTG.Data)
    ReleaseStgMedium tSTG
    Exit Sub
  Else
    Debug.Print "failed cf_unitext"
  End If

---

APIs and String-from-pointer functions:

Code:

---

Public Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell
Public Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long
Public Declare Function lstrcpyA Lib "kernel32" (lpString1 As Any, lpString2 As Any) 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 Const CF_TEXT = 1
Public Const CF_BITMAP = 2
Public Const CF_METAFILEPICT = 3
Public Const CF_SYLK = 4
Public Const CF_DIF = 5
Public Const CF_TIFF = 6
Public Const CF_OEMTEXT = 7
Public Const CF_DIB = 8
Public Const CF_PALETTE = 9
Public Const CF_PENDATA = 10
Public Const CF_RIFF = 11
Public Const CF_WAVE = 12
Public Const CF_UNICODETEXT = 13
Public Const CF_ENHMETAFILE = 14
Public Const CF_HDROP = 15
Public Const CF_LOCALE = 16
Public Const CF_DIBV5 = 17


Public Function GetStrFromPtrA(lpszA As Long) As String
  Dim sRtn As String
  sRtn = String$(lstrlenA(ByVal lpszA), 0)
  Call lstrcpyA(ByVal sRtn, ByVal lpszA)
  GetStrFromPtrA = sRtn
End Function

Public Function LPWSTRtoStr(lPtr As Long, Optional ByVal fFree As Boolean = True) As String
SysReAllocString VarPtr(LPWSTRtoStr), lPtr
If fFree Then
    Call CoTaskMemFree(lPtr)
End If
End Function

---

Thanks. The text drag/drop is working just fine, although I had no (apparent) need for the bAbort variable that was posted in your above code. Anything I need to know about that, please? i.e. what are you using it as a flag for and what actions are you taking in relation to its value?

As for the image types, I have no need of those but was just curious as to how it was done!

Forgot to delete that.. it's easier to test things on existing drop targets so I had a variable to avoid all the drop description editing and file processing if text was being dropped.

Ahh, OK. Thanks again, anyway...

By the way, I've incorporated all of the stuff in this thread to a new project which I've pasted below. Your original download excludes some of the nice stuff that has since been added. You will see that I've coded it to raise events and made it easy to extend as/when the other DataObject formats are addressed (i.e. DIBS, etc)

Disregard if you aren't interested in this approach: I'll probably continue down this path for my purposes as it fits my usage needs.

Again, nice work :)

Form code

Code:

---

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

Private Sub cIDT_FilesDropped(Files() As String, KeyState As Long, Effect As oleexp3.DROPEFFECTS)
  Text1.Text = Join(Files, vbCrLf)
  Effect = DROPEFFECT_NONE 'We didn't do anything with the dropped files here,
End Sub

Private Sub cIDT_TextDropped(Text As String, KeyState As Long, Effect As oleexp3.DROPEFFECTS)
  Text1.Text = Text
  Effect = DROPEFFECT_NONE
End Sub

Private Sub Form_Load()
  Set cIDT = New cDropTarget
  cIDT.Init Picture1.hWnd
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Set cIDT = Nothing
End Sub

---

Class code

Code:

---

Option Explicit

Implements IDropTarget

Private Const CFSTR_DROPDESCRIPTION As String = "DropDescription"
Private Type DROPDESCRIPTION
    type As DROPIMAGETYPE
    szMessage(MAX_PATH - 1) As Integer
    szInsert(MAX_PATH - 1) As Integer
End Type
Private Enum DROPIMAGETYPE
  DROPIMAGE_INVALID = -1
  DROPIMAGE_NONE = 0
  DROPIMAGE_COPY = 1 'DROPEFFECT_COPY
  DROPIMAGE_MOVE = 2 'DROPEFFECT_MOVE
  DROPIMAGE_LINK = 4 'DROPEFFECT_LINK
  DROPIMAGE_LABEL = 6
  DROPIMAGE_WARNING = 7
  DROPIMAGE_NOIMAGE = 8 'Win 7 and above only
End Enum

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

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 SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell
Private Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long
Private Declare Function lstrcpyA Lib "kernel32" (lpString1 As Any, lpString2 As Any) As Long

Private Const CF_TEXT = 1
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Private Const CF_SYLK = 4
Private Const CF_DIF = 5
Private Const CF_TIFF = 6
Private Const CF_OEMTEXT = 7
Private Const CF_DIB = 8
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_RIFF = 11
Private Const CF_WAVE = 12
Private Const CF_UNICODETEXT = 13
Private Const CF_ENHMETAFILE = 14
Private Const CF_HDROP = 15
Private Const CF_LOCALE = 16
Private Const CF_DIBV5 = 17

'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 mHwnd As Long
Private mDataObj As IDataObject
Private mDataFormat As FORMATETC
Event FilesDropped(Files() As String, KeyState As Long, Effect As oleexp3.DROPEFFECTS)
Event TextDropped(Text As String, KeyState As Long, Effect As oleexp3.DROPEFFECTS)
Event UnhandledFormatDropped()

Private Sub Class_Initialize()
Dim dhiid As UUID, 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

Public Sub Init(pHwnd As Long)
  mHwnd = pHwnd
  RegisterDragDrop mHwnd, Me
End Sub

Private Sub Class_Terminate()
  RevokeDragDrop mHwnd
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)
Dim pt As oleexp3.POINT
  Debug.Print "DragEnter"
  pt.x = ptX: pt.y = ptY
 
  pDTH.DragEnter mHwnd, pDataObj, pt, pdwEffect
 
  IDO_AddDropDesc pDataObj, DROPIMAGE_MOVE, "Frob with %1", "MyApp"
  Set mDataObj = pDataObj
  IdentifyObjectFormat

End Sub

Private Sub IDropTarget_DragLeave()
  Debug.Print "DragLeave"
  pDTH.DragLeave
  IDO_AddDropDesc mDataObj, DROPIMAGE_INVALID, "", ""
  Set mDataObj = Nothing
End Sub

Private Sub IDropTarget_DragOver(ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As oleexp3.DROPEFFECTS)
Dim pt As oleexp3.POINT
 
  Debug.Print "DragOver"

  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)
Dim idx As Long, pt As oleexp3.POINT, stg As STGMEDIUM
Dim nFiles As Long, sFiles() As String, i As Long, sBuffer As String, lpText As Long

  Debug.Print "Drop"
 
  pt.x = ptX: pt.y = ptY
  pDTH.Drop pDataObj, pt, pdwEffect
 
  InitDataExtraction
 
  Select Case mDataFormat.cfFormat
      Case CF_HDROP
        pDataObj.GetData mDataFormat, stg
        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
        RaiseEvent FilesDropped(sFiles, grfKeyState, pdwEffect)
      Case CF_TEXT, CF_UNICODETEXT
        pDataObj.GetData mDataFormat, stg
        lpText = GlobalLock(stg.Data)
        If mDataFormat.cfFormat = CF_TEXT Then
            sBuffer = GetStrFromPtrA(lpText)
        Else
            sBuffer = LPWSTRtoStr(lpText, False)
        End If
        Call GlobalUnlock(stg.Data)
        ReleaseStgMedium stg
        RaiseEvent TextDropped(sBuffer, grfKeyState, pdwEffect)
      Case Else
        RaiseEvent UnhandledFormatDropped
  End Select

End Sub

Private Sub IdentifyObjectFormat()
'Brute force, this; is there a better way?

  mDataFormat.cfFormat = CF_BITMAP
  If mDataObj.QueryGetData(mDataFormat) = S_OK Then Exit Sub
 
  mDataFormat.cfFormat = CF_METAFILEPICT
  If mDataObj.QueryGetData(mDataFormat) = S_OK Then Exit Sub
 
  mDataFormat.cfFormat = CF_DIB
  If mDataObj.QueryGetData(mDataFormat) = S_OK Then Exit Sub

  mDataFormat.cfFormat = CF_HDROP
  If mDataObj.QueryGetData(mDataFormat) = S_OK Then Exit Sub
 
  mDataFormat.cfFormat = CF_UNICODETEXT
  If mDataObj.QueryGetData(mDataFormat) = S_OK Then Exit Sub
 
  mDataFormat.cfFormat = CF_TEXT
  If mDataObj.QueryGetData(mDataFormat) = S_OK Then Exit Sub

End Sub

Private Sub InitDataExtraction()
'Apparently this can differ from case-to-case but there will be many similar cases...
  Select Case mDataFormat.cfFormat
      Case CF_HDROP, CF_TEXT, CF_UNICODETEXT
        mDataFormat.TYMED = TYMED_HGLOBAL
        mDataFormat.dwAspect = DVASPECT_CONTENT
        mDataFormat.lindex = -1
  End Select
End Sub

Private Sub IDO_AddDropDesc(ido As oleexp3.IDataObject, nType As DROPIMAGETYPE, sMsg As String, sIns As String)
Dim fmt As FORMATETC, stg As STGMEDIUM, tDD As DROPDESCRIPTION
Dim iTmp1() As Integer, iTmp2() As Integer
Dim hGlobal As Long, lpGlobal As Long
Dim lpFmt As Long, 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
     
      lpFmt = RegisterClipboardFormatW(StrPtr(CFSTR_DROPDESCRIPTION))
     
      fmt.cfFormat = lpFmt
      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(MAX_PATH - 1)
  If Len(sz) > MAX_PATH Then sz = Left$(sz, MAX_PATH)
  For i = 1 To Len(sz)
      iOut(i - 1) = AscW(Mid(sz, i, 1))
  Next i
End Sub
Private Function GetStrFromPtrA(lpszA As Long) As String
Dim sRtn As String
  sRtn = String$(lstrlenA(ByVal lpszA), 0)
  Call lstrcpyA(ByVal sRtn, ByVal lpszA)
  GetStrFromPtrA = sRtn
End Function

Private Function LPWSTRtoStr(lPtr As Long, Optional ByVal fFree As Boolean = True) As String
  SysReAllocString VarPtr(LPWSTRtoStr), lPtr
  If fFree Then
      Call CoTaskMemFree(lPtr)
  End If
End Function

---

Yeah I'm working on a much more full-featured class; every example posted is already implemented in my app, it's just a big step between that and releasing a stand-alone class; plus it's a whole lot of work to get all the options working at once.. like automatically handling drops, custom menu vs. menu associated with handing drops, whether a drop that's handled should be the same event as an unhandled drop; what should be built into the class vs. left to the user, whether XP should be supported and the workarounds and missing features that entails.. not easy :)

Regarding the formats... that approach doesn't consider that the object can have multiple formats. To get a list of formats the dataobject supports:

Code:

---

  Dim pEnumFMT As IEnumFORMATETC
  Set pEnumFMT = pDataObj.EnumFormatEtc(DATADIR_GET)
  Dim tFMTETC As FORMATETC
  Do While (pEnumFMT.Next(1, tFMTETC) = S_OK)
        Debug.Print "dragenter fmt->" & tFMTETC.cfFormat
    Loop

---

The CFSTR_ formats are a little more complicated. You need to register to handle them with RegisterClipboardFormat; then you'd need to store the return values, as those are what's returned in the above.


-----------------------------------------------
Also regarding text drops... while HTML is plain, non-unicode text, the CF_TEXT format is different than the "HTML Format". A drag from a web browser or other HTML source will have both, but CF_TEXT will just contain the unformatted text. To get the HTML-formatted text (which also contains the URL it comes from):

Code:

---

Private CF_HTML As Long
Private Const CFSTR_HTML As String = "HTML Format"
Private Sub Class_Initialize()
'[...]
CF_HTML = RegisterClipboardFormatW(StrPtr(CFSTR_HTML))
End Sub

'[...]
    tFMT.cfFormat = CF_HTML
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL
    If pDataObj.QueryGetData(tFMT) = S_OK Then
      Debug.Print "Got HTML drop"
      pDataObj.GetData tFMT, tSTG
      lpText = GlobalLock(tSTG.Data)
      Debug.Print "html=" & GetStrFromPtrA(lpText)
      ReleaseStgMedium tSTG
    End If

---

There's a few other HTML-related formats, like "text/html"; most of them are just plain strings you can retrieve in an identical manner.
The standard text retrieval also works for CFSTR_UNIFORMRESOURCELOCATOR[W].

---------------------------------
Regarding DIBs, progress will be slow as I really haven't spent too much time with graphics. But the header structure was retrieved as I suspected:
(and this can be changed to CF_DIBV5/BITMAPV5HEADER without issue)

Code:

---

If AcceptFmt(CF_DIB) Then
  tFMT.cfFormat = CF_DIB
  tFMT.dwAspect = DVASPECT_CONTENT
  tFMT.TYMED = TYMED_HGLOBAL
  tFMT.lIndex = -1
  If pDataObj.QueryGetData(tFMT) = S_OK Then
    Debug.Print "Got cf_dib"
    pDataObj.GetData tFMT, tSTG
    Dim lpGlobal As Long
    Dim tBIH As BITMAPINFOHEADER
    lpGlobal = GlobalLock(tSTG.Data)
    CopyMemory tBIH, ByVal lpGlobal, LenB(tBIH)
    Debug.Print "dib bitcnt=" & tBIH.biBitCount
    Debug.Print "dib width=" & tBIH.biWidth
    Call GlobalUnlock(tSTG.Data)
    ReleaseStgMedium tSTG
    Exit Sub
  End If
End If

---

When you put it that way I guess there is quite a lot left to do!

Anyway, if somebody comes along and wants something that encapsulates the various disparate posts in this thread, they will have the option to use the 'merged' stuff in #20....

Cheers!

So we can now add CFSTR_FILECONTENTS/CFSTR_FILEGROUPDESCRIPTOR to the list (drops like Outlook attachments or from a ZIP opened in Explorer)...
It seems quite a few people use the Outlook attachment drop method from the original olelib projects; and they can't be used together with this class because you don't want more than one IDropTarget for a control. Now this method contains an updated method that works to save Outlook attachments (and any other FileContents drop, something the old example didn't include).

The issue that popped up here is that different apps put data in different places. Explorer gives you the file name in the IStream.stat type, but Outlook doesn't, and instead only gives it in the group descriptor.
This also uses the extremely useful but undocemented vbaObjSetAddRef. Up until now, everything has been accessible with TYMED_HGLOBAL, but here that's no longer the case. We need TYMED_ISTREAM. But VB doesn't support unions, so we're stuck with the single .data member that just contains a Long. Fortunately, that long contains a pointer to the IStream object we need, and vbaObjSetAddRef(pStrm, tSTG.data) gives us that IStream. This method is a bit simpler than previous Outlook attachment methods, like E. Morcillo's class, and handles the general case because of the differences we mentioned.
Also note that this code uses the W (unicode) types; changing over to the ANSI ones is trivial* and the final class will include it, but since there's so little difference I'm just posting the one here.
The code uses mSaveFileContents and mFileContentsPath as enabling options, be sure to set those or change the code to not use them; but the save path must exist.

Code:

---

    Dim nFiles As Long, sFCN() As String
    tFMT.cfFormat = CF_FILEGROUPDESCRIPTORW
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL
    If pDataObj.QueryGetData(tFMT) = S_OK Then
        Debug.Print "got group description"
        pDataObj.GetData tFMT, tSTG
        lpGlobal = GlobalLock(tSTG.Data)
        Dim gSize As Long
        gSize = GlobalSize(tSTG.Data)
        Debug.Print "gsize=" & gSize
        Dim fgd As FILEGROUPDESCRIPTORW, sTmp As String
        Dim tFD As FILEDESCRIPTORW
        CopyMemory fgd, ByVal lpGlobal, LenB(fgd)
        Debug.Print "citems=" & fgd.cItems
        nFiles = fgd.cItems - 1
        ReDim sFCN(nFiles)
        For idx = 0 To (fgd.cItems - 1)
            CopyMemory tFD, ByVal lpGlobal + 4& + Len(tFD) * idx, Len(tFD)
            Debug.Print "idx=" & idx & "size h/l=" & tFD.nFileSizeHigh & "/" & tFD.nFileSizeLow
            Debug.Print "name=" & CStr(tFD.cFileName)
            sFCN(idx) = tFD.cFileName
        Next
        Call GlobalUnlock(tSTG.Data)
        ReleaseStgMedium tSTG
    End If
    For idx = 0 To nFiles
    tFMT.cfFormat = CF_FILECONTENTS
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.TYMED = TYMED_ISTREAM
    tFMT.lIndex = idx
    If pDataObj.QueryGetData(tFMT) = S_OK Then
        Debug.Print "got file contents drop"
        Dim hr As Long, pstrm As IStream, tStat As STATSTG, pStrmFile As IStream
        hr = pDataObj.GetData(tFMT, tSTG)
        Debug.Print "hr=" & hr & ",got data=" & tSTG.Data
        vbaObjSetAddRef pstrm, tSTG.Data
        If (pstrm Is Nothing) Then
            Debug.Print "pstrm not set"
        Else
            pstrm.stat tStat
            Debug.Print "cbsize=" & tStat.cbSize * 10000
            Dim sName As String, pszPath As String
            Dim cbSize As Currency
            sName = SysAllocString(tStat.pwcsName)
            Debug.Print "name(" & tStat.pwcsName & ")=" & sName
            If mSaveFileContents Then
                Debug.Print "saving..."
                If (sFCN(idx) = "") Then
                    pszPath = AddBackslash(mFileContentsPath) & sName
                Else
                    pszPath = AddBackslash(mFileContentsPath) & sFCN(idx)
                End If
                Call SHCreateStreamOnFileEx(StrPtr(pszPath), STGM_CREATE Or STGM_WRITE, FILE_ATTRIBUTE_NORMAL, 1, 0, pStrmFile)
                If (pStrmFile Is Nothing) Then
                    Debug.Print "Failed to create new file"
                Else
                    Debug.Print "Writing new file... " & pszPath
                    pstrm.CopyTo pStrmFile, tStat.cbSize, 0, cbSize
                    Set pStrmFile = Nothing
                End If
            End If
        End If
        Set pstrm = Nothing
        ReleaseStgMedium tSTG
    End If
    Next

---

* - Change FILEGROUPDESCRIPTORW/FILEDESCRIPTORW to FILEGROUPDESCRIPTORA/FILEDESCRIPTORA, and when getting the name in the descriptor, use sFCN(idx) = StrConv(tFD.cFileName, vbUnicode)

FileContents with TYMED_ISTORAGE
So if you drop an entire email from Outlook, you can't get an IStream directly for it (fails). But you can save the entire .msg like this:

Code:

---

            If (pstrm Is Nothing) Then
                Debug.Print "pstrm not set, will try IStorage"
                tFMT.cfFormat = CF_FILECONTENTS
                tFMT.dwAspect = DVASPECT_CONTENT
                tFMT.TYMED = TYMED_ISTORAGE
                tFMT.lIndex = idx
                hr = pDataObj.GetData(tFMT, tSTG)
                Debug.Print "istorage hr=" & hr & ",data=" & tSTG.Data
                Dim pStgF As oleexp.IStorage
                Dim pStgMem As oleexp.IStorage
                sTargetDir = mFileContentsPath
                If sFCN(idx) = "" Then
                    Debug.Print "don't have name"
                    sFCN(idx) = "filedoe.msg"
                   
                End If
                pszPath = AddBackslash(sTargetDir) & sFCN(idx)
                Set pStgMem = StgCreateDocfile(pszPath, STGM_CREATE Or STGM_READWRITE Or STGM_SHARE_EXCLUSIVE)
                vbaObjSetAddRef pStgF, tSTG.Data

                If (pStgF Is Nothing) Then
                    Debug.Print "Failed to get IStorage from IDO"
                Else
                    Debug.Print "Got IStorage from IDO, saving... " & pszPath
                    Dim tIID As UUID
                    pStgF.CopyTo 0, tIID, "", pStgMem
                    Set pStgMem = Nothing
                    Set pStgF = Nothing
                    ReleaseStgMedium tSTG
                    Exit Function
                End If
                   
            End If

---

--------------------------------------------------------
FileContents with only TYMED_HGLOBAL
I'll crosspost this here as well...
Firefox FileContents drops were quite weird. I have no idea if any other applications do this, but if anyone encounters something like this elsewhere I want to know.
-GetData with TYMED_ISTREAM fails
-GetData with TYMED_HGLOBAL succeeds... but it's not really an HGLOBAL; CreateStreamOnHGlobal produces an empty stream with zero size (but it's not 'Nothing')
-The .data from the HGlobal GetData is used to set the stream with vbaObjSetAddRef... it looked like all was good until:
-The IStream isn't a completely valid IStream-- pStrm.CopyTo produces an error saying "Object doesn't support this action." Huh?
-But it at least did support .Read, and its .stat returned the correct size... so it had to be manually copied:

Code:

---

                              Dim pvB() As Byte
                              ReDim pvB(nSize)
                              pstrm.Read pvB(0), nSize
                              pStrmFile.setSize tStat.cbSize
                              pStrmFile.Write pvB(0), nSize
                              pStrmFile.Commit

---

-And so the question is... will this appropriately handle all cases where TYMED_ISTREAM isn't supported but TYMED_HGLOBAL is? Or do other applications actually provide an HGlobal that can't be set to an IStream? So please advise of any other apps that only show TYMED_HGLOBAL for FileContents.

In the mean time, if you feel like venturing into this unusual thing.. here's what I did to support FileContents with TYMED_HGLOBAL but not TYMED_ISTREAM... I don't know if it will work with other applications.. let me know. This doesn't effect the groupdescriptor processing, just replaces the filecontents processing:

Code:

---

    Dim bUnlock As Boolean
       
    For idx = 0 To nFiles
    tFMT.cfFormat = CF_FILECONTENTS
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.TYMED = TYMED_ISTREAM
    tFMT.lIndex = idx
    If pDataObj.QueryGetData(tFMT) = S_OK Then
        Debug.Print "got file contents drop"
        Dim hr As Long, pstrm As IStream, tStat As STATSTG, pStrmFile As IStream
        hr = pDataObj.GetData(tFMT, tSTG)
        Debug.Print "hr=" & hr & ",got data=" & tSTG.Data
        If hr = S_OK Then
            vbaObjSetAddRef pstrm, tSTG.Data
        Else
            'for some reason, TYMED_ISTREAM will return S_OK on QueryGetData even if it's not supported
            'so we'll see if we get a valid hglobal
            tFMT.cfFormat = CF_FILECONTENTS
            tFMT.dwAspect = DVASPECT_CONTENT
            tFMT.TYMED = TYMED_HGLOBAL
            tFMT.lIndex = idx
            hr = pDataObj.GetData(tFMT, tSTG)
            Debug.Print "hglobal hr=" & hr & ",got data=" & tSTG.Data
            vbaObjSetAddRef pstrm, tSTG.Data
            lpGlobal = GlobalLock(tSTG.Data)
            Debug.Print "size=" & GlobalSize(tSTG.Data)
            bUnlock = True
'            Call CreateStreamOnHGlobal(tSTG.Data, 1, pstrm)
            If (pstrm Is Nothing) Then
                Debug.Print "failed to set pstrm with hglobal"
            Else
                Debug.Print "set stream via hglobal"
            End If
        End If
            If (pstrm Is Nothing) Then
                Debug.Print "pstrm not set"
            Else
                pstrm.stat tStat
                Dim nSize As Long
                nSize = tStat.cbSize * 10000
                Debug.Print "cbsize=" & tStat.cbSize * 10000
                Dim sName As String, pszPath As String, sTargetDir As String
                Dim cbSize As Currency
                sName = SysAllocString(tStat.pwcsName)
                Debug.Print "name(" & tStat.pwcsName & ")=" & sName
                If mSaveFileContents Then
                    Debug.Print "saving..."
                    If mFCinCP Then
                        sTargetDir = IIf(sFolder = "", mCurPath, sFolder)
                    Else
                        sTargetDir = mFileContentsPath
                    End If
                    If PathFileExistsW(StrPtr(sTargetDir)) Then
                        If (sFCN(idx) = "") Then
                            pszPath = AddBackslash(sTargetDir) & sName
                        Else
                            pszPath = AddBackslash(sTargetDir) & sFCN(idx)
                        End If
                        Call SHCreateStreamOnFileEx(StrPtr(pszPath), STGM_CREATE Or STGM_WRITE, FILE_ATTRIBUTE_NORMAL, 1, 0, pStrmFile)
                        If (pStrmFile Is Nothing) Then
                            Debug.Print "Failed to create new file"
                        Else
                            If bUnlock Then
                            'bizarre method where CopyTo isn't supported
                              Dim pvB() As Byte
                              ReDim pvB(nSize)
                              Debug.Print "reading pstrm into byte array..."
                              pstrm.Read pvB(0), nSize
                              Debug.Print "pstrm read, writing to new stream..."
                              pStrmFile.setSize tStat.cbSize
                              pStrmFile.Write pvB(0), nSize
                              Debug.Print "wrote pstrmfile, committing"
                              pStrmFile.Commit
                            Else
                                Debug.Print "Writing new file... " & pszPath
                                pstrm.CopyTo pStrmFile, tStat.cbSize, 0, cbSize
                               
                                Debug.Print "bytes written=" & cbSize
                            End If
                            Set pStrmFile = Nothing
                        End If
                    End If
                End If
            End If
            Set pstrm = Nothing
            If bUnlock Then Call GlobalUnlock(tSTG.Data)
            ReleaseStgMedium tSTG
           
    Else
        Debug.Print "Failed QueryGetData on FileContents"
    End If
    Next

---

Note that you'll have to break things up and do multiple writes if you want to handle files with a size > ~2GB (where size can't fit in a long)

Making progress, I see...

By the way, I noticed that IDO_AddDropDesc does not work for CF_UNICODETEXT/CF_TEXT: No error, just no description rendered...


EDIT: Also meant to mention that your cursor X/Y positions (throughout) are relative to the screen and not the control that is registered as a drop target. Easily remedied via GetWindowRect but thought I'd mention it...

Yeah dropdescription only seems to work on file drops.

Does the point reference frame effect anything in the code (something not working right) or just something to note if you were planning on doing something else with the coords?

That's a shame about the dropdescription :(

As for the MouseXY, it's just a matter of convenience. In my modified class I raise all the drag/drop events (Enter, Over, Leave, Drop) in order to change things like the drop description (much the same way as you do in your ListView example except, of course, I do it outside of my D'n'D class). In all cases, I am having to convert the mouse co-ords via GetWindowRect so that they are meaningful in relation to the drop target.

The IDataObject is implemented by the application that's the drag source, so the supported formats depends on whether is has been implemented or not. Files (or a dragsource from SHCreateDataObject, which is unique in that it's the only time you can get an IDataObject from Explorer without implementing your own) come from Explorer, which does. Other apps and types don't.

To find out which formats can be used with .SetData, you can use IDataObject.EnumFormatEtc with DATADIR_SET.


Edit: Would like some input on this... how many people are actually using this under XP? I was thinking about how this can replace the entirety of the outdated VB OLEDragDrop... and my comment above having to implement your own IDataObject class to drag other formats...

It turns out the Vista+ SHCreateDataObject isn't limited to files; you can pass all nulls and get a generic, empty data object that supports adding any format. Is this benefit worth nuking XP support?

So I've made some significant progress towards an advanced general purpose drop target class that includes all the stuff from this thread... it's really shaping up now. Even came up with a good way to optionally implement the dragover stuff for LV/TV/etc.

Attached is just a preview of what the class is shaping up to be. The DragOver in file view query events are responded to like this now (see LVDragOverFolder above):

Code:

---

Private Sub LVDT_QueryDragOverData(in_ItemIndex As Long, in_fIsGroup As Boolean, out_FullPath As String)
If in_fIsGroup Then
    out_FullPath = GroupGetPathForFolder(in_ItemIndex)
Else
    Dim lp As Long
    lp = GetLVItemlParam(LVDT.DropHWND, in_ItemIndex)
    out_FullPath = glbRes(lp).sFullPath
End If
End Sub

Private Sub LVDT_QueryDragOverItem(in_ptX As Long, in_ptY As Long, in_PrevIndex As Long, out_NewIndex As Long, out_fGroup As Boolean)
Dim pt As oleexp3.POINT
pt.X = in_ptX
pt.Y = in_ptY
out_NewIndex = LVDragOverFolder(LVDT.DropHWND, pt, in_PrevIndex, out_fGroup)
End Sub

---

And the ListView version is being initialized like this:

Code:

---

Set LVDT = New cDropTarget
LVDT.DropHWND = hLVS
If bAllowDDOps Then
    LVDT.DefaultEffect = DROPEFFECT_COPY
    LVDT.DragHighlight = True
    LVDT.HandleFileDrop = True
End If
LVDT.AddAllowedFormat CF_MAX
LVDT.SaveFileContents True, "C:\temp2\FileContentsTest"
Call CoLockObjectExternal(ObjPtr(LVDT), 1, 0)
dwRtn = RegisterDragDrop(hLVS, LVDT)

---

And my image preview control looks like this:

Code:

---

Set cPrvDrop = New cDropTarget
cPrvDrop.DropHWND = Picture4.hWnd
cPrvDrop.DrawImagesToControl = True
cPrvDrop.SetDrawImageControl Picture4.hWnd, Picture4.hDC, 0, 0
cPrvDrop.AddAllowedFormat CF_MAX
cPrvDrop.DefaultEffect = DROPEFFECT_COPY
cPrvDrop.SetDropTip "Preview", "", DROPIMAGE_LABEL
RegisterDragDrop Picture4.hWnd, cPrvDrop

---

Let me know what approaches are good or bad, or what needs to still be done as far as formats, or options...
Some options I'll probably add before release: Save image drops that don't have FileContents, TreeView dragover example, and a few others that temporarily slipped my mind. The class also uses stuff from the new oleexp3 v3.2 that I released just for this upcoming project (it has a bunch of dragdrop declares and structs). I think I got everything declared that's not in the TLB. But I don't have a sample project or form yet, just the class for preview (way too big for a post, 1300+ lines).

Since I don't need much of this functionality, I'm continuing with my own scaled-down implementation. So, I added the various RegisterClipboardFormatW lines to my own code, in Class_Initialise, and CFSTR_HTML and CFSTR_RTF throw up 'Variable not defined'. Using v3.2 of oleexp3.

Only just started looking at the new class, so nothing else to report at this time...

So I was writing some code to use this class with a TreeView, and wanted to replicate the expand-on-hover of Explorer.

So the first step was making a generic DragHover event:

Code:

---

Private Declare Function GetTickCount Lib "kernel32" () As Long

Private lHover1 As Long, lHover2 As Long
Private xHover As Long, yHover As Long
Private lRaiseHover As Long 'NOT SHOWN BUT NEEDED: set a default value in Class_Initialize. I use 2500 (2.5 seconds)
Private bHoverFired As Boolean

Public Event DragHover(X As Long, Y As Long, lKeyState As Long)

Public Property Let HoverTime(lMillisecs As Long): lRaiseHover = lMillisecs: End Property
Public Property Get HoverTime() As Long: HoverTime = lRaiseHover: End Property

Private Sub IDropTarget_DragOver(ByVal grfKeyState As Long, ByVal ptx As Long, ByVal ptY As Long, pdwEffect As oleexp3.DROPEFFECTS)
If (xHover <> ptx) Or (yHover <> ptY) Then
    lHover1 = GetTickCount()
    xHover = ptx
    yHover = ptY
    bHoverFired = False
Else
    If lHover1 = 0 Then 'initial run
        lHover1 = GetTickCount()
        xHover = ptx
        yHover = ptY
    Else
        If bHoverFired = False Then
            lHover2 = GetTickCount()
            If (lHover2 - lHover1) > lRaiseHover Then
                RaiseEvent DragHover(ptx, ptY, grfKeyState)
                bHoverFired = True 'set flag to not raise again until pt changes
            End If
        End If
    End If
End If

'[...] - end of added code; the rest of IDropTarget_DragOver is omitted

---

Now that we have a DragHover event (use not limited to or dependent on a treeview, useful for many situations with many controls), we can do autoexpand like this:

Code:

---

Private Sub cTVDrop_DragHover(X As Long, Y As Long, lKeyState As Long)
Dim tvhti As TVHITTESTINFO
Dim ppt As oleexp3.POINT
ppt.X = X
ppt.Y = Y
Call ScreenToClient(hTVD, ppt)
tvhti.pt.X = ppt.X
tvhti.pt.Y = ppt.Y
TreeView_HitTest hTVD, tvhti
If (tvhti.Flags And TVHT_ONITEM) Then
    TreeView_Expand hTVD, tvhti.hItem, TVE_EXPAND
End If

End Sub
Public Function TreeView_Expand(hWnd As Long, hItem As Long, dwFlags As Long) As Boolean
    TreeView_Expand = SendMessage(hWnd, TVM_EXPAND, ByVal dwFlags, ByVal hItem)
End Function

---

Getting closer to a release of this epic drop target class.. plan on getting it out before the new year.

edit: so apparently jmsrickland is allowed to delete his own posts. for reference, he told me never to bother posting code (not even full projects, even conceptual code not intended to be production-ready) unless it was 100% copy-paste-run, and there wasn't a single missing constant to look up, or a single typo, or a single line that has to be adjusted to work on XP. And even error free isn't good enough, he further stated I also shouldn't bother unless thorough error checking and sanity checking is already done.


So anyway, back to fun things. I'm not going to make new posts unless I'm up against the post length limit or someone replies, but I did want to post another status update.

To expedite things like saving, or doing your own image drawing/manipulation, in addition to the already supplied hGlobal handle, the class now also has events ImageHandleGDIP and ImageHandleHBITMAP, which give you an hImage or hBitmap that's easier to work with. The PNG handler already used GDI+ which could use its create from stream function, but CF_DIBV5 wasn't using GDI+ already, and can't be created via IStream. But thanks to some help from the graphics god LaVolpe, there's now an hImage that can for example be passed off straight to gdipSaveImageToFile:
(immediately after setting lRead in Drop_DIBV5)

Code:

---

Dim i As Long
Dim aBy() As Byte
Dim bi5 As BITMAPINFO5
Dim hImage As Long
Dim hBmp As Long

            ReDim aBy(nGlb - 1)
            CopyMemory aBy(0), ByVal lpGlobal, nGlb
            ReDim aDat5((UBound(aBy) - tBIH5.bV5Size))
            For i = tBIH5.bV5Size To UBound(aBy) 'read from byte 124 to end
                aDat5(i - tBIH5.bV5Size) = aBy(i)
            Next
            bi5.bmiHeader = tBIH5
            GdipCreateBitmapFromGdiDib bi5, VarPtr(aDat5(0)), hImage
            If hImage Then
                RaiseEvent ImageHandleGDIP(hImage, CF_DIBV5)
                GdipCreateHBITMAPFromBitmap hImage, hBmp, 0&
                RaiseEvent ImageHandleHBITMAP(hBmp, CF_DIBV5)
                GdipDisposeImage hImage
                DeleteObject hBmp
            End If

---

And the class marches further towards production. It will be THE definitive drop target class; just drop in the class and attach it to a control, and you've got everything from the basic drag images and drops all the way through crazy advanced stuff all handled.


Disclaimer for the haters: As right now this code is conceptual: it shows those already familiar with this topic the concepts of how to do stuff. It is a guide to implement a working and functional concept, not a standalone-absolutely-100%-complete masterpiece. It is not a codebank project (yet), it is not production ready, it does not contain all appropriate sanity checks and error handling, it does not contain some standard Windows APIs and definitions, and is not designed for copy-paste-run. If you are not proficient enough to handle the known, standard, trivial, or searchable details to raise it to that level, do not ruin things for those that are, because nobody is obligated to write code to suit those who can only copy and paste.

Been exploring this great class, however I haven't been able to determine DropTargets.

i/e if I have 5 picture boxes, how would you know which PictureBOX you've dropped the File on?
I presume we need a separate Function to calculate x/y pos of the Mouse? or is there a way to return the name/hWnd of the dropped control?

Are you registering multiple hWnds to the same drop object? The class is designed for one instance per hWnd, and has a variable that stores that information, m_hWnd. Some functionality won't even work if you tried to register multiple hWnds, as the DropTargetHelper needs one passed to it.

Set it up as 1 per target, e.g.
Private cDropPic1 As cDropTarget
Private cDropPic2 As cDropTarget
and so forth. Then you'll know both by virtue of which object receives the dragdrop and the hWnd stored in the class itself.

Quote:

---

Originally Posted by fafalone

Are you registering multiple hWnds to the same drop object? The class is designed for one instance per hWnd, and has a variable that stores that information, m_hWnd. Some functionality won't even work if you tried to register multiple hWnds, as the DropTargetHelper needs one passed to it.

Set it up as 1 per target, e.g.
Private cDropPic1 As cDropTarget
Private cDropPic2 As cDropTarget
and so forth. Then you'll know both by virtue of which object receives the dragdrop and the hWnd stored in the class itself.

---

Yes, I finally figured out I needed separate instances of the class to have more control.

I have 2 more question :)
1)
How would I go about showing Icons if I wanted to drag/drop inApp.
So I have a custom control (lynxGrid) and I want to drag items from it on to another Button....
I can't seem to figure out how to show the ICON when dragging from the lynxGrid.
Any help?

2)Seem to work with most objects and forms (new proj / new form), but on my Main Project Form the RegisterDragDrop on the Attach returns -2147221247. It can't seem to hook on. Any reasons as to why?
(yes my OLEDropMode is 0)

1) Assuming you mean dropping onto targets registered using this method?
-If you're dragging and dropping files, use the SHDoDragDrop API normally.
-For other formats, see this project.

2) That error is named DRAGDROP_E_ALREADYREGISTERED; you sure it hasn't been made a drop target in any other way? I can't seem to reproduce it; can register forms fine. OS version, and since it's saying already registered, can you drop on it, and if so does it show the cDropTarget image or does the OLEDragDrop/DragDrop method fire when you drop?

Quote:

---

Originally Posted by fafalone

2) That error is named DRAGDROP_E_ALREADYREGISTERED; you sure it hasn't been made a drop target in any other way? I can't seem to reproduce it; can register forms fine. OS version, and since it's saying already registered, can you drop on it, and if so does it show the cDropTarget image or does the OLEDragDrop/DragDrop method fire when you drop?

---

I've never used the RegisterDragDrop API in my project, so I have no idea how it may have been already a DropTarget.
But Imanaged to resolve this issue by simply detaching and re-attaching the hWnd.

Code:

---

Public Function Attach(hWnd As Long, Optional objName As String) As Long
'after configuring settings, call this to attach to an hWnd
m_hWnd = hWnd
m_ObjName = objName
Dim xRes As Long
xRes = RegisterDragDrop(hWnd, Me)
If xRes = DRAGDROP_E_ALREADYREGISTERED Then
  Detach
  Attach = RegisterDragDrop(hWnd, Me)
Else
    Attach = xRes
End If
End Function

---

Hi Fafalone,

Got a new issue with some users running the app without UAC on win7, and naturally everything is run with Admin privilages.
As far as I know, VB/Windows has a security issue with drag & drop when run the app as Admin.

Is there any workaround to this, to be able to Drag & Drop whilst the .exe is run with Admin rights?

I believe it can be resolved by setting the UIAccess=true flag in the manifest, cryptographically signing the app, and installing it to the Program Files folder. But the cert has to be from a trusted authority (i.e. PAY UP!); you could add your own trusted root authority, but it's quite the pain, and it would have to be done on each computer you want to run on.

I now have a authorised code sign certificate.
The .exe is signed.
in program files (x86)
and UIAccess =True


But still same issue. Unable to drag/drop.

Any ideas?

Internal manifest?

Some related threads:
http://www.vbforums.com/showthread.p...levated-VB-App
http://www.vbforums.com/showthread.p...p-on-Windows10

I made an x64-supporting version of this project in twinBASIC, with the interfaces defined right in the project instead of a TLB.

Not as virtual objects either, tB has a specific feature for using interfaces:

Code:

---

[ InterfaceId ("4657278B-411B-11D2-839A-00C04FD918D0") ]
Interface IDropTargetHelper Extends stdole.IUnknown
    Sub DragEnter(ByVal hwndTarget As LongPtr, ByVal pDataObject As DragDropDemo.IDataObject, ppt As POINT, ByVal dwEffect As DROPEFFECTS)
    Sub DragLeave()
    Sub DragOver(ppt As POINT, ByVal dwEffect As DROPEFFECTS)
    Sub Drop(ByVal pDataObject As DragDropDemo.IDataObject, ppt As POINT, ByVal dwEffect As DROPEFFECTS)
    Sub Show(ByVal fShow As Long)
End Interface

---

[twinBASIC] Explorer-style Drag-Drop Images with tB-defined x86+x64 interfaces

Quote:

---

Originally Posted by fafalone

Yeah I'm working on a much more full-featured class; every example posted is already implemented in my app, it's just a big step between that and releasing a stand-

Code:

---

If AcceptFmt(CF_DIB) Then
  tFMT.cfFormat = CF_DIB

---

---

what's AcceptFmt?

When I drop files with filenames' lenght exceeding MAX_PATH DragQueryFileW fails in Windows 10. I don't know if it fails in other versions. In those cases the clipboard format is CF_HDROP, which doesn't seem very specific...

I'm using an early version of cDropTarget.cls, the one which size is 4.744 bytes. This works OK with oleexp501.tlb. There are a few updates that don't seem to deal with the issue.

Is there a workaround for this issue?

Have you tried the method in post #2?

has anyone figured out how to drag drop across privilege levels? I have tried various messages with ChangeWindowMessageFilterEx but havent found the right combo for drag drop yet

Quote:

---

Originally Posted by fafalone

Have you tried the method in post #2?

---

I didn't but I may if you think it may do the trick. By the way, great work! Thanks!

Yes I read somewhere that by Windows 10, IShellItem could support long path names.

Great! I'll give it a try. Thanks!

Quote:

---

Originally Posted by dz32

has anyone figured out how to drag drop across privilege levels? I have tried various messages with ChangeWindowMessageFilterEx but havent found the right combo for drag drop yet

---

The official way to do it is enable UIAccess in the manifest. In addition to that, your exe must be signed and reside in a trusted location like Program Files.

I was actually looking at another, undocumented, way of doing it the other day, but I haven't tried it yet; if you run as SYSTEM (e.g. with my RunAsTI app, although I believe you'd need to modify it to steal the token from lsass.exe instead), you can enable SeTcbPrivilege and set the UiAccess token privilege; the article wasn't real clear on if this also bypassed the trusted location requirement. I'll give it a try later today.

Cool :) I will basically never use a manifest, be signed or run from program files lol. Fingers crossed on the token method!

Bad news; I was able to start programs with UIAccess enabled on the token, but it doesn't bypass the trusted location and signature requirements :(

Edit: Even more bad news, apparently self-signed certificates are no longer good enough.

Aghh sucks. From and usability standpoint I really miss xp in a number of ways !

Quote:

---

Originally Posted by fafalone

Have you tried the method in post #2?

---

Sorry to bother you. Can you please attach a complete example of that? I've been messing with it for 2 hours now and I'm lost.

I basically pasted the code from post #2 into the project attached on post #1, but I don't know what to do now. I don't see LVDH defined anywhere so I just commented out the line for the test. I also defined "Dim IID_IShellItemArray As UUID" because I don't see it defined. I don't know what to do with it. Then IDropTarget_Drop is called when I drop files into Picture1 but after the call to "SHCreateShellItemArrayFromDataObject(pDataObj, IID_IShellItemArray, psia)" psia contains Nothing. I guess I'm getting all wrong.

It's meant as an alternative to the DragQueryFiles method. First, the zip download containing oleexp.tlb comes with a file called mIID.bas, add that (Project menu->Add File...) so all the IID_ symbols are available. Then you'd replace the code in the cIDT_Drop event with

Code:

---

Private Sub cIDT_Drop(pDataObj As oleexp.IDataObject, grfKeyState As Long, ptx As Long, pty As Long, pdwEffect As oleexp.DROPEFFECTS)
    Dim psia As IShellItemArray
    Dim piesi As IEnumShellItems
    Dim pItem As IShellItem
    Dim lpFile As Long
    Dim pcl As Long
    Call SHCreateShellItemArrayFromDataObject(pDataObj, IID_IShellItemArray, psia)
    If (psia Is Nothing) = False Then
        psia.EnumItems piesi
        Do While (piesi.Next(1, pItem, pcl) = NOERROR)
            pItem.GetDisplayName SIGDN_FILESYSPATH, lpFile
            Debug.Print "Dropfile " & LPWSTRtoStr(lpFile)
        Loop
    End If
End Sub
Private Function LPWSTRtoStr(lPtr As LongPtr, Optional ByVal fFree As Boolean = True) As String
SysReAllocStringW VarPtr(LPWSTRtoStr), lPtr
If fFree Then
    Call CoTaskMemFree(lPtr)
End If
End Function

---

Thanks a lot, fafalone! That was it! It's working now.
I just droped a 289 characters pathname file and it's displayed correctly prepended with "\\?".
I wonder if this could also work on XP 32 bit. I guess not, but I'll check anyway.

Unfortunately SHCreateShellItemArrayFromDataObject, IEnumShellItems, and IShellItemArray are only available on Vista+, so it would work on Windows 7, but not XP. You could do something similar to get IShellItem representations; but I don't think they supported long paths on XP anyway. And that would be a pain to do, as so few IShellItem helper APIs were available on XP. You'd have to manually examine the IDataObject for the CFSTR_SHELLIDLIST format and extract it.

You're completely right. I checked that a few hours ago. None of those functions exist in XP. In the explorer the files with pathname lenght exceeding MAX_PATH are shown with their filenames truncated and the context menu offers very few items. Yo can't rename, move, copy or open the file. Even in the cmd window the names are shown truncated. I guess this mean that not just the shell is affected. But you're allowed to rename the folders up in the hierarchy containing the file, thus making the file useable again.

For using your code in XP and in W10 without modification I just included both methods (Shell & DragQueryFiles) in the Drop event handler. If the call to SHCreateShellItemArrayFromDataObject fails with error 453 then I use the DragQueryFiles method. This seems to work in XP and in W10.

Thanks again, you've been very helpful !

I would check the behavior on Win7 and 8 too because even though those APIs and interfaces are supported, I'm not sure if they had long path name support prior to 10. Of course it would be like XP and not work in Explorer either.

I don't currently have W8 or W7 to check that.

I have a wmp control in my form and I want to set it as drop target but its hWnd is not exposed, not as a property neither Spy++ detects it. Is there a way to achieve this?