dcsimg
Results 1 to 36 of 36

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

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    [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.3
    '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.
    '
    '(c) 2016 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) As Long
    'after configuring settings, call this to attach to an hWnd
    m_hWnd = hwnd
    Attach = RegisterDragDrop(hwnd, Me)
    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 oleexp3.POINT
       pt.x = ptx
       pt.y = pty
       
       pDTH.DragEnter m_hWnd, pDataObj, pt, pdwEffect
        
        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
    
    pDTH.Drop pDataObj, pt, pdwEffect
    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
    Attached Files Attached Files

  2. #2

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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.

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

  3. #3
    Lively Member
    Join Date
    Oct 2008
    Posts
    111

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

    Hello
    running on XP sp3 I get Run-Time error 430
    Code:
    Set pDTH = New DragDropHelper

  4. #4

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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

  5. #5
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,073

    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.

  6. #6

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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.

  7. #7
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,073

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

    Quote Originally Posted by fafalone View Post
    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 View Post
    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 View Post
    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.

  8. #8

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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.

  9. #9
    PowerPoster
    Join Date
    Jan 2008
    Posts
    11,073

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

    Quote Originally Posted by fafalone View Post
    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.

  10. #10

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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.

  11. #11

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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)

  12. #12
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,082

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

    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'
    If you don't know where you're going, any road will take you there...

    My VB6 love-children: Vee-Hive and Vee-Launcher

  13. #13

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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

  14. #14
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,082

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

    OK, i had already corrected it in my code to what you posted above but, alas, it doesn't work on XP SP3
    If you don't know where you're going, any road will take you there...

    My VB6 love-children: Vee-Hive and Vee-Launcher

  15. #15

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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.

    All the other things should work though.

  16. #16
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,082

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

    My VB6 love-children: Vee-Hive and Vee-Launcher

  17. #17

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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

  18. #18
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,082

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

    My VB6 love-children: Vee-Hive and Vee-Launcher

  19. #19

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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.

  20. #20
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,082

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

    My VB6 love-children: Vee-Hive and Vee-Launcher

  21. #21

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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

  22. #22
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,082

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

    My VB6 love-children: Vee-Hive and Vee-Launcher

  23. #23

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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)

  24. #24
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,082

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

    My VB6 love-children: Vee-Hive and Vee-Launcher

  25. #25

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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?

  26. #26
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,082

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

    My VB6 love-children: Vee-Hive and Vee-Launcher

  27. #27

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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?

  28. #28

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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)
    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).
    Attached Files Attached Files

  29. #29
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,082

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

    My VB6 love-children: Vee-Hive and Vee-Launcher

  30. #30

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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.

  31. #31

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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.

  32. #32
    Frenzied Member some1uk03's Avatar
    Join Date
    Jun 2006
    Location
    London, UK
    Posts
    1,480

    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.



  33. #33

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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.

  34. #34
    Frenzied Member some1uk03's Avatar
    Join Date
    Jun 2006
    Location
    London, UK
    Posts
    1,480

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

    Quote Originally Posted by fafalone View Post
    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.



  35. #35

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    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?

  36. #36
    Frenzied Member some1uk03's Avatar
    Join Date
    Jun 2006
    Location
    London, UK
    Posts
    1,480

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

    Quote Originally Posted by fafalone View Post
    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.



Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width