[VB6] Register any control as a drop target that shows the Explorer drag image
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
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.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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
Last edited by fafalone; Oct 29th, 2015 at 07:08 AM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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
Anything I post is an example only and is not intended to be the only solution, the total solution nor the final solution to your request nor do I claim that it is. If you find it useful then it is entirely up to you to make whatever changes necessary you feel are adequate for your purposes.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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)
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
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_????
Anything I post is an example only and is not intended to be the only solution, the total solution nor the final solution to your request nor do I claim that it is. If you find it useful then it is entirely up to you to make whatever changes necessary you feel are adequate for your purposes.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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:
Is that what you're trying for?
And yes, if you copied the file to a new location you should return DROPEFFECT_COPY.
Last edited by fafalone; Oct 29th, 2015 at 08:08 PM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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: 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)
Anything I post is an example only and is not intended to be the only solution, the total solution nor the final solution to your request nor do I claim that it is. If you find it useful then it is entirely up to you to make whatever changes necessary you feel are adequate for your purposes.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
If you change the default effect to DROPEFFECT_MOVE, it looks like this:
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.
Last edited by fafalone; Oct 30th, 2015 at 02:18 PM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
Changing the Drop Description
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:
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.
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)
Last edited by fafalone; Nov 24th, 2016 at 04:14 PM.
Reason: Fixed offset bug in DROPDESCRIPTION
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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?
If you don't know where you're going, any road will take you there...
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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
Last edited by fafalone; Nov 8th, 2015 at 02:38 PM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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!
If you don't know where you're going, any road will take you there...
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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
Last edited by ColinE66; Nov 8th, 2015 at 04:10 PM.
If you don't know where you're going, any road will take you there...
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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
Last edited by fafalone; Nov 9th, 2015 at 12:16 AM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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!
If you don't know where you're going, any road will take you there...
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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)
Last edited by fafalone; Nov 24th, 2016 at 04:16 PM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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...
Last edited by ColinE66; Nov 19th, 2015 at 02:24 PM.
If you don't know where you're going, any road will take you there...
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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?
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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.
Last edited by ColinE66; Nov 19th, 2015 at 05:25 PM.
If you don't know where you're going, any road will take you there...
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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?
Last edited by fafalone; Nov 20th, 2015 at 12:14 AM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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)
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).
Last edited by fafalone; Nov 20th, 2015 at 04:55 AM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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...
If you don't know where you're going, any road will take you there...
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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.
Last edited by fafalone; Nov 25th, 2015 at 08:07 PM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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.
Last edited by fafalone; Dec 4th, 2015 at 03:54 AM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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?
_____________________________________________________________________
----If this post has helped you. Please take time to Rate it.
----If you've solved your problem, then please mark it as RESOLVED from Thread Tools.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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)
Last edited by some1uk03; Nov 29th, 2018 at 08:08 AM.
_____________________________________________________________________
----If this post has helped you. Please take time to Rate it.
----If you've solved your problem, then please mark it as RESOLVED from Thread Tools.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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?
Last edited by fafalone; Nov 30th, 2018 at 01:24 AM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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
_____________________________________________________________________
----If this post has helped you. Please take time to Rate it.
----If you've solved your problem, then please mark it as RESOLVED from Thread Tools.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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?
_____________________________________________________________________
----If this post has helped you. Please take time to Rate it.
----If you've solved your problem, then please mark it as RESOLVED from Thread Tools.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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.
Last edited by fafalone; Jun 16th, 2020 at 08:19 PM.
Re: [VB6] Register any control as a drop target that shows the Explorer drag image
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?
_____________________________________________________________________
----If this post has helped you. Please take time to Rate it.
----If you've solved your problem, then please mark it as RESOLVED from Thread Tools.
Reply With Quote
Originally Posted by fafalone
