dcsimg
Results 1 to 36 of 36

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

Threaded View

  1. #1

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

    [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

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