Results 1 to 3 of 3

Thread: [VB6] Drag drop any format to other apps without custom IDataObject

  1. #1

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

    [VB6] Drag drop any format to other apps without custom IDataObject


    3 Aug 2016 UPDATE: This is fairly complex stuff so I've added a sample project. The sample project also has functions for added a few more formats, and receives text too. An updated cDropTarget class was made more portable and easy to use; it's not the super-involved one I'm working on, it just pushes events out with the IDataObject for the project to handle elsewhere. Also, dropping PNGs in the same process they were created in caused a heap corruption crash, this has been fixed by making the dataobject module-level so it doesn't prematurely go out of scope and get freed.

    While I've got a thread going about how to do this the right way and actually implement an IDataObject, in the mean time I thought I'd post a trick that you can use to dragdrop any format without one.

    Normally, to drag text to another app, you'd have to create an implementation of IDataObject in a class, then implement all its methods and support CF_TEXT and/or CF_UNICODETEXT and others you wanted. However, if you were just looking to copy files with CF_HDROP, you may have seen my other project where there's an API that does this for you-- SHCreateDataObject. There's not a direct equivalent for any other CF_ format, but it turns out that you can call that API without actually specifying a file, and still get back a fully functional default IDataObject from Windows instead of rolling your own custom one, which you can then add your desired formats to. This is still far less code and far easier than providing a custom implementation.

    Requirements
    -Windows Vista or higher*
    -oleexp.tlb version 4.0 or higher with mIID.bas

    Code
    Primary code to create and drag, typically called from a MouseDown event:
    Code:
    Public Declare Function SHCreateDataObject Lib "shell32" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pdtInner As Any, riid As UUID, ppv As Any) As Long
    Public Declare Function SHDoDragDrop Lib "shell32" (ByVal hwnd As Long, ByVal pdtobj As Long, ByVal pdsrc As Long, ByVal dwEffect As Long, pdwEffect As Long) As Long
    
    Public Sub DoDrag()
    Dim pDataObj As oleexp.IDataObject
    
    Call SHCreateDataObject(0&, 0&, 0&, ByVal 0&, IID_IDataObject, pDataObj)
    
    If (pDataObj Is Nothing) Then
        Debug.Print "couldn't get ido"
    Else
        Debug.Print "got ido"
        IDO_AddTextW pDataObj, "TextWTest"
        IDO_AddTextA pDataObj, "TextATest"
        Dim lp As Long
        Dim hr As Long
        hr = SHDoDragDrop(Me.hwnd, ObjPtr(pDataObj), 0&, DROPEFFECT_COPY, lp)
        Set pDataObj = Nothing
    End If
    End Sub
    The example above adds two formats to the blank IDataObject, CF_TEXT (IDO_AddTextA) and CF_UNICODETEXT (IDO_AddTextW):
    Code:
    Public Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Public Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) 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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    
    Public Sub IDO_AddTextW(ido As oleexp3.IDataObject, sText As String)
    Dim fmt As FORMATETC
    Dim stg As STGMEDIUM
    Dim hGlobal As Long, lpGlobal As Long
    Dim sz As String
    sz = sText & vbNullChar
    hGlobal = GlobalAlloc(GPTR, LenB(sz))
    If hGlobal Then
        lpGlobal = GlobalLock(hGlobal)
        Call CopyMemory(ByVal lpGlobal, ByVal StrPtr(sz), LenB(sz))
        Call GlobalUnlock(hGlobal)
        stg.TYMED = TYMED_HGLOBAL
        stg.Data = lpGlobal
        fmt.cfFormat = CF_UNICODETEXT
        fmt.dwAspect = DVASPECT_CONTENT
        fmt.lIndex = -1
        fmt.TYMED = TYMED_HGLOBAL
        ido.SetData fmt, stg, 1
    End If
    
    End Sub
    Public Sub IDO_AddTextA(ido As oleexp.IDataObject, sText As String)
    Dim fmt As FORMATETC
    Dim stg As STGMEDIUM
    Dim hGlobal As Long, lpGlobal As Long
    Dim b() As Byte
    
    hGlobal = GlobalAlloc(GPTR, Len(sText) + 1)
    If hGlobal Then
        lpGlobal = GlobalLock(hGlobal)
        b = StrConv(sText & vbNullChar, vbFromUnicode)
        CopyMemory ByVal lpGlobal, b(0), UBound(b) + 1
        Call GlobalUnlock(hGlobal)
        stg.TYMED = TYMED_HGLOBAL
        stg.Data = lpGlobal
        fmt.cfFormat = CF_TEXT
        fmt.dwAspect = DVASPECT_CONTENT
        fmt.lIndex = -1
        fmt.TYMED = TYMED_HGLOBAL
        ido.SetData fmt, stg, 1
    End If
    End Sub
    You can follow the same basic procedure to add any formats you want to your IDataObject. As another example, here's how to drag a PNG image from the file on disk, which shows the technique for dragging file contents:

    Code:
    Public Declare Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As Long) As Long
    Public Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
    Public Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
    Public Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
    Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    
    Public Const FILE_READ_DATA = &H1
    Public Const FILE_SHARE_READ = &H1&
    Public Const OPEN_EXISTING = 3&
    
    Public Sub IDO_AddPNG(pDataObj As oleexp.IDataObject, sPng As String)
    Dim fmt As FORMATETC
    Dim stg As STGMEDIUM
    Dim hGlobal As Long, lpGlobal As Long
    Dim hFile As Long, nFile As Long, lp As Long
    Dim bPNG() As Byte
    hFile = CreateFileW(StrPtr(sPng), FILE_READ_DATA, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
    If hFile Then
        nFile = GetFileSize(hFile, lp)
        Debug.Print "high=" & nFile & ",low=" & lp
        ReDim bPNG(nFile)
        ReadFile hFile, bPNG(0), nFile, lp, 0&
        CloseHandle hFile
        If lp > 0& Then
    
        hGlobal = GlobalAlloc(GPTR, UBound(bPNG) + 1)
        If hGlobal Then
            lpGlobal = GlobalLock(hGlobal)
            CopyMemory ByVal lpGlobal, bPNG(0), UBound(bPNG) + 1
            Call GlobalUnlock(hGlobal)
            stg.TYMED = TYMED_HGLOBAL
            stg.Data = lpGlobal
            fmt.cfFormat = RegisterClipboardFormatW(StrPtr(CFSTR_PNG))
            fmt.dwAspect = DVASPECT_CONTENT
            fmt.lIndex = -1
            fmt.TYMED = TYMED_HGLOBAL
            pDataObj.SetData fmt, stg, 1
        End If 'memalloc
    
        End If 'bytesread>0
    End If
    End Sub
    You can add multiple formats to the same object; it's the drop target that decides which it can accept and display.

    Since it's a custom format, we don't get the benefit of a default icon anymore. But making a drag image isn't too hard; we can use the IDragSourceHelper interface for that. If you've got a control you're dragging from that does drag images, you can use InitializeFromWindow, but if you want full control you can create the entire image yourself. Here's an IDO_AddPNGEx routine that does just that:
    Code:
    Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
    Public Declare Function SHCreateItemFromIDList Lib "shell32" (ByVal pidl As Long, riid As UUID, ppv As Any) As Long
    Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell
    
    Public Sub IDO_AddPNGEx(pDataObj As oleexp.IDataObject, sPng As String)
    Dim fmt As FORMATETC
    Dim stg As STGMEDIUM
    Dim hGlobal As Long, lpGlobal As Long
    Dim lpFmt As Long
    Dim hFile As Long, nFile As Long, lp As Long
    Dim bPNG() As Byte
    hFile = CreateFileW(StrPtr(sPng), FILE_READ_DATA, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
    If hFile Then
        nFile = GetFileSize(hFile, lp)
        Debug.Print "high=" & nFile & ",low=" & lp
        ReDim bPNG(nFile)
        ReadFile hFile, bPNG(0), nFile, lp, 0&
        CloseHandle hFile
        If lp > 0& Then
            hGlobal = GlobalAlloc(GPTR, UBound(bPNG) + 1)
            If hGlobal Then
                lpGlobal = GlobalLock(hGlobal)
                CopyMemory ByVal lpGlobal, bPNG(0), UBound(bPNG) + 1
                Call GlobalUnlock(hGlobal)
                stg.TYMED = TYMED_HGLOBAL
                stg.Data = lpGlobal
                fmt.cfFormat = CF_PNG
                fmt.dwAspect = DVASPECT_CONTENT
                fmt.lIndex = -1
                fmt.TYMED = TYMED_HGLOBAL
                pDataObj.SetData fmt, stg, 1
                
                'set thumbnail for drag
                Dim pHelper As IDragSourceHelper2
                Set pHelper = New DragDropHelper
                Dim tImg As SHDRAGIMAGE
                GetFileThumbForIDSH sPng, tImg
                pHelper.SetFlags 0&
                pHelper.InitializeFromBitmap tImg, pDataObj
            End If
        End If
    End If
    End Sub
    Private Sub GetFileThumbForIDSH(sFile As String, tSDI As SHDRAGIMAGE, Optional cx As Long = 16, Optional cy As Long = 16)
    'This method is Vista-only; you can fall back to IExtractImage or others if you're trying to support XP still
    Dim pidl As Long
    Dim isiif As IShellItemImageFactory
    pidl = ILCreateFromPathW(StrPtr(sFile))
    Call SHCreateItemFromIDList(pidl, IID_IShellItemImageFactory, isiif)
    If (isiif Is Nothing) = False Then
        isiif.GetImage cx, cy, SIIGBF_THUMBNAILONLY, tSDI.hbmpDragImage
        tSDI.sizeDragImage.cx = cx
        tSDI.sizeDragImage.cy = cy
    '        tSDI.ptOffset.x = 15 'you can add an offset to see it better, but the drop x,y won't change
    '        tSDI.ptOffset.Y = 15
    Else
        Debug.Print "GetFileThumbForIDSH::Failed to get IShellItemImageFactory"
    End If
    Call CoTaskMemFree(pidl)
    End Sub
    A 32x32 drag image thumbnail of a PNG being dragged, next to it after being dropped and rendered at full size (see next post):


    And finally, you can also set a default drop description (although drop targets frequently set their own):

    First, in IDO_AddPNGEx, change pHelper.SetFlags 0& to pHelper.SetFlags DSH_ALLOWDROPDESCRIPTIONTEXT
    Then immediately after IDO_AddPNGEx, add IDO_AddDropDesc pDataObj, DROPIMAGE_LABEL, "Drop %1 here", "MyPNG"
    Code:
    Public 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 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
        fmt.cfFormat = RegisterClipboardFormatW(StrPtr(CFSTR_DROPDESCRIPTION)) 'CF_DROPDESCRIPTION
        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(255)
    For i = 1 To Len(sz)
        iOut(i - 1) = AscW(Mid(sz, i, 1))
    Next i
    End Sub
    --------------------------------
    * - Normally I would use the undocumented SHCreateFileDataObject and retain XP support, but with this usage the IDataObject it creates returns with several additional formats inserted with blank or corrupt data. If XP support is a requirement you can try it and see if the form
    Attached Files Attached Files

  2. #2

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

    Re: [VB6] Code Snippet: Drag drop any format to other apps without custom IDataObject

    For those curious, also wanted to show how you could accept a dragged PNG and show it in a Picturebox, when your control is registered as a modern IDropTarget:

    Code:
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As Any) As Long  ' lpPoint As POINTAPI) As Long
    Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
    Private Declare Function GdipLoadImageFromStream Lib "GDIplus" (ByVal stream As IUnknown, Image As Long) As Long
    Private Declare Function GdipCreateFromHDC Lib "GdiPlus.dll" (ByVal hDC As Long, GpGraphics As Long) As Long
    Private Declare Function GdipGetImageWidth Lib "GdiPlus.dll" (ByVal Image As Long, Width As Long) As Long
    Private Declare Function GdipGetImageHeight Lib "GdiPlus.dll" (ByVal Image As Long, Height As Long) As Long
    Private Declare Function GdipDrawImageRectRectI Lib "GdiPlus.dll" (ByVal graphics As Long, ByVal GpImage As Long, ByVal dstx As Long, ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal srcx As Long, ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As Long, ByVal imageAttributes As Long, ByVal callback As Long, ByVal callbackData As Long) As Long
    Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal graphics As Long) As Long
    Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal Image As Long) As Long
    Private Declare Function GdiplusStartup Lib "GDIplus" (ByRef Token As Long, ByRef lpInput As GdiplusStartupInput, Optional ByRef lpOutput As Any) As Long
    Private Declare Function GdiplusShutdown Lib "GDIplus" (ByVal Token As Long) As Long
    Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
    Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Const RDW_UPDATENOW As Long = &H100
    Private Const RDW_INVALIDATE As Long = &H1
    Private Const RDW_ERASE As Long = &H4
    Private Const RDW_ALLCHILDREN As Long = &H80
    
    Private Function DoDrop_PNG(pDataObj As oleexp.IDataObject, pt As oleexp.POINT) As Long
    Dim tFMT As FORMATETC
    Dim tSTG As STGMEDIUM
    Dim lpGlobal As Long
    Dim hGlobal As Long
    
    'if you want the coords of the mouse on the control:
    Dim pt2 As oleexp.POINT
    pt2.x = pt.x
    pt2.Y = pt.Y
    ScreenToClient Picture1.hWnd, pt2
    
    tFMT.cfFormat = RegisterClipboardFormatW(StrPtr(CFSTR_PNG)) 'CF_PNG
    tFMT.dwAspect = DVASPECT_CONTENT
    tFMT.lIndex = -1
    tFMT.TYMED = TYMED_HGLOBAL
    
    Debug.Print "Got PNG drop"
    pDataObj.GetData tFMT, tSTG
    If tSTG.Data Then
            hGlobal = tSTG.Data
            lpGlobal = GlobalLock(hGlobal)
            Dim pIStrm As IStream
            Dim hImage As Long
            Dim hGraphics As Long
            Dim CX As Long, CY As Long
            
            Call CreateStreamOnHGlobal(hGlobal, 1, pIStrm)
            If (pIStrm Is Nothing) Then
                Debug.Print "DoDrop_PNG::Failed to create IStream"
                Exit Function
            End If
            GdipLoadImageFromStream pIStrm, hImage
            
            If GdipCreateFromHDC(Picture1.hDC, hGraphics) = 0 Then
                GdipGetImageWidth hImage, CX
                GdipGetImageHeight hImage, CY
    
    '            GdipDrawImageRectRectI hGraphics, hImage, 0, 0, CX, CY, 0, 0, CX, CY, &H2, 0, 0&, 0& 'Render at 0,0
                GdipDrawImageRectRectI hGraphics, hImage, pt2.x, pt2.Y, CX, CY, 0, 0, CX, CY, &H2, 0, 0&, 0& 'render at mouse position
    
                GdipDeleteGraphics hGraphics
                
            End If
    
            GdipDisposeImage hImage
            RedrawWindow Picture1.hWnd, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN
            UpdateWindow Picture1.hWnd
            
            GlobalUnlock hGlobal
    End If
    ReleaseStgMedium tSTG
    
    End Function

  3. #3

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

    Re: [VB6] Drag drop any format to other apps without custom IDataObject

    UPDATED
    Since this is so complex I've turned it into a full sample project, hopefully that will make this technique more accessible.

    Also a few bug fixes to the original code posted; see post #1.

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
  •  



Click Here to Expand Forum to Full Width