dcsimg
Results 1 to 14 of 14

Thread: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDrop

  1. #1

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

    [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDrop



    It took many months of wasting hours, giving up, and revisiting to finally get a working solution, and the only previous VB solution was monstrously complex. I understand very few people will find this useful, but wanted to share anyway due to the lack of answers I found while trying to get it working and the simplicity over other solutions.

    NEW: A NOTE ON DRAG IMAGES
    The project hasn't been updated, but I wanted to add on some new information about the drag image. As you may have noted, multiple files just have the number without the icon unless you drag over certain apps, and the modern drag image doesn't show at all in the source control. These are both caused by the same thing: a modern drag source like ours is also supposed to use the latest drop target functionality. If you register your control as a drop target with the modern methods (see this project), the 100%-identical-to-Explorer image for multiple files will show from the start now and carry over to Explorer. You don't need to actually allow drop functionality; a registered drop target whose effect is DROP_EFFECT_NONE is just as good.

    Background
    DragDrop functionality is easy if you're using, say, VB's ListView, but what if you're using a ListView created via CreateWindowEx that has no OLEStartDrag/OLESetData with pre-provided DataObject, and want to start a drag operation that can be dragged around Windows Explorer (or any drop target accepting dropped files)? Previous solutions have used the DoDragDrop API and then had to implement their own IDataObject and IDropSource interfaces, and I had yet to see one that supported multiple paths. Turns out that unless you require other-than-default behavior, you accomplish a full drag-to-explorer operation in just a few lines of code. The SHDoDragDrop API provides both a default drag source and a default drag icon showing the number of files, just like Explorer. It also supports the action options menu if you drag with the right button. And no further action is required, the receiving program handles the operation.

    The included sample project doesn't use any subclassed/CreateWindowEx ListViews, but does show how you can initiate the operation from any arbitary point in code given a list of files.

    Update
    As discussed in posts below, the code as-is produces a clipboard object missing a few formats. But there is an undocumented shell function that, as a drop-in replacement with no other recoding needed, will create the object with additional formats CF_HDROP, FileName, and FileNameW, as well as show menu options added by 3rd party programs like WinRAR. SHCreateDataObject can be replaced with SHCreateFileDataObject, which is exported by ordinal-only, but the same ordinal from XP through 8.1:
    Code:
    Public Declare Function SHCreateFileDataObject Lib "shell32" Alias "#740" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pDataInner As Any, ppDataObj As oleexp.IDataObject) As Long
    
    Call SHCreateFileDataObject(pidlDesk, cpidl, VarPtr(apidl(0)), ByVal 0&, iData)

    Also see below for voxy's post on how to add even more formats manually by using the IDataObject.SetData method.

    And one last new technique... while I still haven't cracked exactly how to duplicate Explorer's drag image, a better drag image than the project, showing the items as they appear in a ListView is possible if that's where the drag originates from. This may work with other controls too- specifying the originating hWnd in SHDoDragDrop.

    Requirements
    This code does require a typelib with the IDataObject interface such as oleexp) or OLEGuids to be added as a reference. Works with XP and above if you use SHCreateFileDataObject; or Vista and above if you use SHCreateDataObject.
    Attached project references oleexp.tlb v4.0 or higher

    For the purposes of the below code, we'll assume you have your own routine to enumerate the full paths of the files that are selected. This code will typically be for a Begin Drag notification, such as LVN_BEGINDRAG.

    Code:
    Public Sub InitDrag(sSelFullPath() As String)
    Dim hr0 As Long
    Dim iData As IDataObject
    Dim apidl() As Long
    Dim cpidl As Long
    Dim rpidl As Long
    Dim pidlDesk As Long
    Dim lRetDD As Long
    Dim i As Long
    Dim AllowedEffects As DROPEFFECTS
    Call SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, pidlDesk) 'we support multiple paths by creating an IDataObject with the desktop as the root and then supplying fully qualified pidls rather than child pidls
    
    'EnumSelectedFiles - Whatever routine you have to get your selected files list, a standard routine like
    '  Do
    '     i = ListView_GetNextItem(hLVS, i, LVNI_SELECTED)
    '     If (i <> LVI_NOITEM) Then
    ReDim apidl(UBound(sSelFullPath)) 'sSelFullPath would then contain the full path to the file, C:\folder\file.ext, //Computer/folder/file.ext
    For i = 0 To UBound(apidl)
           apidl(i) = GetPIDLFromPathW(sSelFullPath(i)) 'support function to return fully qualified pidls for each file, see below
    Next i
    cpidl = UBound(apidl) + 1
    Call SHCreateDataObject(pidlDesk, cpidl, VarPtr(apidl(0)), ByVal 0&, IID_IDataObject, iData) 'even though the desktop pidl is just the zero-terminator, don't confuse that with passing zero instead of this-- results in an invalid drag source that can't be dropped anywhere
    If iData Is Nothing Then
        Debug.Print "Failed to created IDataObject"
        Exit Sub
    End If
                
    AllowedEffects = DROPEFFECT_COPY Or DROPEFFECT_MOVE Or DROPEFFECT_LINK
    
    hr0 = SHDoDragDrop(0&, ObjPtr(iData), 0, AllowedEffects, lRetDD) 'theoretically you can supply your own IDropSource implementation, but I never got it working
    
    Debug.Print "hr0=" & hr0 & ",lRet=" & lRetDD 'hr0 contains the HRESULT of the call, and lRetDD is the result of the operation, see the full DROPEFFECT description for all possible values
    Call CoTaskMemFree(pidlDesk)
    For i = 0 To UBound(apidl)
        Call CoTaskMemFree(apidl(i))
    Next i
    Set iData = Nothing
    
    End Sub
    'If instead this is in a WndProc, you'll probably want to cancel the notification by returning 1 and exiting before a DefWndProc call.
    
    'Supporting declares and functions:
    Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
    Public Const CSIDL_DESKTOP = &H0
    Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) ' Frees memory allocated by the shell
    
    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 Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
    Public Function GetPIDLFromPathW(sPath As String) As Long
       GetPIDLFromPathW = ILCreateFromPathW(StrPtr(sPath))
    End Function
    Public Function IID_IDataObject() As UUID
    '0000010e-0000-0000-C000-000000000046
    Static IID As UUID
     If (IID.Data1 = 0) Then Call DEFINE_UUID(IID, &H10E, CInt(&H0), CInt(&H0), &HC0, &H0, &H0, &H0, &H0, &H0, &H0, &H46)
      IID_IDataObject = IID
    End Function
    Public Sub DEFINE_UUID(Name As UUID, l As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
      With Name
        .Data1 = l
        .Data2 = w1
        .Data3 = w2
        .Data4(0) = B0
        .Data4(1) = b1
        .Data4(2) = b2
        .Data4(3) = B3
        .Data4(4) = b4
        .Data4(5) = b5
        .Data4(6) = b6
        .Data4(7) = b7
      End With
    End Sub
    You can specify your own drag image with something like LVM_CREATEDRAGIMAGE, but when dragged into Explorer the standard one is overlayed on top of it, here's a simple technique that creates a drag image of the selected items icon:
    Code:
    'from http://www.mvps.org/emorcillo/en/code/vb6/listviewdragdropimage.shtml
    Public Sub ListView_StartDrag( _
       ByVal hWndListView As Long, _
       Optional ByVal X As Long = 20, _
       Optional ByVal Y As Long = 20)
    Dim tPoint As POINTAPI
    Dim LITEM As Long
    
       ' Get the selected item
       LITEM = SendMessage(hWndListView, LVM_GETNEXTITEM, -1, ByVal LVNI_SELECTED)
    
       ' Get a ImageList with
       ' the drag image
       m_lIL = SendMessage(hWndListView, LVM_CREATEDRAGIMAGE, LITEM, tPoint)
    
       ' Start the image dragging
       ImageList_BeginDrag m_lIL, 0, X, Y
       ImageList_DragEnter 0, 0, 0
    
       ' Start the timer
       m_lTimer = SetTimer(0, 0, 1, AddressOf pvTimerDragMove)
    
    End Sub
    Public Sub DragComplete()
       
       ' Stop the timer
       KillTimer 0, m_lTimer
    
       ' End the image dragging
       ImageList_EndDrag
       
       ' Destroy the ImageList
       ImageList_Destroy m_lIL
       
    End Sub
    Private Sub pvTimerDragMove( _
       ByVal hWnd As Long, _
       ByVal uMsg As Long, _
       ByVal idEvent As Long, _
       ByVal dwTime As Long)
    Dim tPoint As POINTAPI
       
       ' Get the cursor position
       GetCursorPos tPoint
    
       ' Move the image to the new cursor position
       ImageList_DragMove tPoint.X, tPoint.Y
       
    End Sub
    Attached Files Attached Files

  2. #2
    Member
    Join Date
    Jan 2015
    Posts
    40

    Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro

    Hi fafalone,

    wow, brilliant stuff!!!

    It works pretty much out of the box, but there is something missing compared to a drag initiated by Explorer. The following missing formats are expected by some drop targets:
    CF_HDROP
    FileName
    FileNameW
    FileContents
    FileGroupDescriptorW

    Especially FileContents is something I'm trying to get working for a long time without success. It has to be ISTREAM, but the VB DataObject nor the olelib IDataObject seem to accept ISTREAM. Any idea how to add that to IDataObject?

    Thanks!
    voxy

  3. #3

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

    Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro

    You might be able to add the format in... the IDataObject created should be a standard data object. But the difficulty in working with that is the whole reason for my post... it's extremely difficult to do anything, and most other things require implementing your own entire version, which despite very closely imitating an object-virtualization based implementation, I've never really been able to rework.

    IDataObject.SetData isn't clear whether it would kill the other formats (although I believe it should append it, since MSDN says SHCreateDataObject supports added methods). I had tested some code for adding a CF_HDROP back when i was trying to roll my own, you could give this method a try:
    Code:
    Dim ido As oleexp.IDataObject
    Dim pUnk As oleexp.IUnknown
    Dim i As Long
    Dim fmt As FORMATETC
    Dim stg As STGMEDIUM
    Dim objClsid As GUIDA
    Dim s As String
    Dim df As oleexp.DROPFILES
    Dim hGlobal As Long
    Dim lpGlobal As Long
    Dim hr As Long
    
    For i = 0 To 1
        s = s & "C:\a" & i & ".txt" & vbNullChar
    Next i
    s = s & vbNullChar
    hGlobal = GlobalAlloc(GHND, Len(df) + Len(s))
    
    If hGlobal Then
        lpGlobal = GlobalLock(hGlobal)
    
        ' Build DROPFILES structure in global memory.
        df.pFiles = Len(df)
        Call CopyMemory(ByVal lpGlobal, df, Len(df))
        Call CopyMemory(ByVal (lpGlobal + Len(df)), ByVal s, Len(s))
        Call GlobalUnlock(hGlobal)
    
    fmt.cfFormat = CF_HDROP
    fmt.dwAspect = DVASPECT_CONTENT
    fmt.lIndex = -1
    fmt.pDVTARGETDEVICE = 0
    fmt.TYMED = TYMED_HGLOBAL
    
    stg.TYMED = TYMED_HGLOBAL
    stg.Data = lpGlobal
    
    ido.SetData fmt, stg, 1
    See also the method for converting DataObject to IDataObject (reversible?)

    Also, the STGMEDIUM .data member is actually a union that should support IStream, you should be able to set it to ObjPtr(istream), with TYMED then being TYMED_ISTREAM; check MSDN for how other things should be set. Both the stdmedium and formatetc passed to .SetData must match on TYMED.
    Code:
    typedef struct tagSTGMEDIUM {
      DWORD    tymed;
      union {
        HBITMAP       hBitmap;
        HMETAFILEPICT hMetaFilePict;
        HENHMETAFILE  hEnhMetaFile;
        HGLOBAL       hGlobal;
        LPOLESTR      lpszFileName;
        IStream       *pstm;
        IStorage      *pstg;
      };
      IUnknown *pUnkForRelease;
    } STGMEDIUM, *LPSTGMEDIUM;
    I'll try a few of these things out later on, bed time for me.


    Edit: Very interesting comment on MSDN; there's an undocumented function called SHCreateFileDataObject that the member says creates it with both the shell id list (like in my code) and the CF_HDROP.
    Try this declare, usage shouldn't be be different
    Public Declare Function SHCreateFileDataObject Lib "shell32" Alias "#740" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pDataInner As Any, ppDataObj As oleexp.IDataObject)

    (untested, if that doesn't work try changing the 'ppDataObj As idataobject' to 'riid As UUID, ppv As Any')

    Finally, be aware that the inner data object on both declares is supposed to be used for additional formats- if you could make a VB data object with the format you want (to bypass the lack of "As New IDataObject" possibility) and convert it to an IDataObject, you could set that parameter to ByVal ObjPtr(dataobjwithnewformat)

  4. #4
    Member
    Join Date
    Jan 2015
    Posts
    40

    Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro

    Yes, I got it working!!!

    Note that I could not use SHCreateFileDataObject -- it crashed the IDE (Win 8.1) with all signatures I tried.

    So I added the missing formats one-by-one, and even the dreaded ISTREAM miraculously just worked this time. (I did not use the inner data object.)

    Question: If I don't want the multiple paths support, what do I change in the code? (PS: Okay, probably pass the pidl of the parent folder for pidlDesk.)

    Thanks very much, you helped me a lot me once again!
    Last edited by voxy; May 21st, 2015 at 12:06 PM.

  5. #5

  6. #6
    Member
    Join Date
    Jan 2015
    Posts
    40

    Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro

    Filename (ANSI):
    Code:
      ' FileName ---------------------------------------------------
      sFileName = sItems(0) & vbNullChar
      hGlobal = GlobalAlloc(GHND, Len(sFileName))
      If hGlobal <> 0 Then
        lpGlobal = GlobalLock(hGlobal)
        Call CopyMemory(ByVal lpGlobal, ByVal sFileName, Len(sFileName))
        Call GlobalUnlock(hGlobal)
      
        fmt.cfFormat = CF_FileName
        fmt.dwAspect = DVASPECT_CONTENT
        fmt.lIndex = -1
        fmt.pDVTARGETDEVICE = 0
        fmt.TYMED = TYMED_HGLOBAL
        
        stg.TYMED = TYMED_HGLOBAL
        stg.Data = lpGlobal
        
        IDO.SetData fmt, stg, 1
      End If
    FilenameW (UNICODE):
    Code:
      sFileName = sItems(0) & vbNullChar
      hGlobal = GlobalAlloc(GHND, LenB(sFileName)) ' LenB for UNICODE
      If hGlobal <> 0 Then
        lpGlobal = GlobalLock(hGlobal)
        Call CopyMemory(ByVal lpGlobal, ByVal StrPtr(sFileName), LenB(sFileName))
        Call GlobalUnlock(hGlobal)
      
        fmt.cfFormat = CF_FileNameW
        fmt.dwAspect = DVASPECT_CONTENT
        fmt.lIndex = -1
        fmt.pDVTARGETDEVICE = 0
        fmt.TYMED = TYMED_HGLOBAL
        
        stg.TYMED = TYMED_HGLOBAL
        stg.Data = lpGlobal
        
        IDO.SetData fmt, stg, 1
      End If
    FileContents:
    Code:
    Private Declare Function SHCreateStreamOnFileW_VB Lib "shlwapi.dll" Alias "SHCreateStreamOnFileW" ( _
        ByVal szFile As Long, ByVal grfMode As Long, ppstm As IStream) As Long
    - - - - 
      Dim cntFiles As Long
      Dim Streams() As IStream
      cntFiles = UBound(sItems) + 1
      ReDim Streams(cntFiles - 1)
      SHCreateStreamOnFileW_VB StrPtr(sItems(0)), STGM_READ, Streams(0)
         
      fmt.cfFormat = CF_FILECONTENTS
      fmt.dwAspect = DVASPECT_CONTENT
      fmt.lIndex = -1
      fmt.pDVTARGETDEVICE = 0
      fmt.TYMED = TYMED_ISTREAM
      
      stg.TYMED = TYMED_ISTREAM
      stg.Data = ObjPtr(Streams(0))
      
      ' weak release (tip by Olaf Schmidt)
      CopyMemory Streams(0), 0&, 4
      
      IDO.SetData fmt, stg, 1
    (Yes, I only use the stream of the first file. It seems to work. I'm not sure what Explorer does here.)

    Let me know if you need more.

  7. #7

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

    Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro

    Cool, it's great when things actually work the way you expect them to.

    Regarding SHCreateFileDataObject, you did remember to correct my omission of 'As Long' right? It doesn't crash, at least on Win7.

    Code:
    Public Declare Function SHCreateFileDataObject Lib "shell32" Alias "#740" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pDataInner As Any, ppDataObj As olelib.IDataObject) As Long
    
    Call SHCreateFileDataObject(pidlDesk, cpidl, VarPtr(apidl(0)), ByVal 0&, iData)
    I just had a chance to test it, and it works.
    It creates the IDataObject with not only CF_HDROP, but also FileName and FileNameW.
    AND... it even shows custom drag and drop actions like 7-zip and WinRAR add, without any additional code!


    My first thought on the crashing would be that you just passed 0 on the pDataInner argument, instead of ByVal 0&, which crashes the IDE on both functions.

  8. #8
    Member
    Join Date
    Jan 2015
    Posts
    40

    Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro

    OK, now SHCreateFileDataObject works. And it actually creates all I need: CF_HDROP, FileName, FileContents, FileNameW, FileGroupDescriptorW. So this is the way, great!

    BTW, it crashed because I copied the function declaration from your first post where the "As Long" was missing at the end.

    Some other things:

    - SHDoDragDrop totally takes over the mouse pointer. I cannot set any custom pointers via VB while the mouse is over my app. Correct? Or is there a way to use those DragImageBits in the DataObject to show the cool half-transparent drag image over my app? (I'm not using a ListView control, btw.)

    - SHCreateDataObject appears to be Vista onwards, not XP onwards. (Not tested, just what the MSDN docs say.)

    - You say "SHCreateFileDataObject ... it even shows custom drag and drop actions like 7-zip and WinRAR add, without any additional code!" Yes, but I get those actions also when using SHCreateDataObject.
    Last edited by voxy; May 22nd, 2015 at 01:34 AM.

  9. #9

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

    Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro

    Yeah sorry about the As Long thing, had been awake for a good 24-hours when I was writing that post. If SHCreateDataObject isn't available in XP, the good news is that SHCreateFileDataObject definitely is. I really wonder why MS has never supported it.

    For custom pointers, you mean the actual mouse pointer or the drag image? Don't think there's any easy way to change the pointer, but the drag image can be changed. If you don't specify any hWnd in SHDoDragDrop, is it not showing the transparent blue box like in the main picture up top? If not, you can subclass the window for DI_GETDRAGIMAGE and return false according to a comment thread on MSDN, or custom draw it: https://social.msdn.microsoft.com/Fo...suidevelopment

    Were you getting those extra menu items before adding in the extra formats, or just after?
    And sorry one last question... what are you using to validate formats? If you're seeing FileGroupDescriptorW without manually adding it I've gotta figure out if it's just not being generated on my system or if ClipSpy just doesn't support it.

  10. #10
    Member
    Join Date
    Jan 2015
    Posts
    40

    Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro

    I get the transparent blue box, but not over my VB6 app. There is just the standard small mouse pointer (showing "+" for copy, etc). And when using SHDoDragDrop I cannot customize it using Screen.MousePointer = vbCustom. But thanks for the hint, I'll try the subclassing...

    >Were you getting those extra menu items before adding in the extra formats, or just after?
    Oh, sorry, forget what I said. I'm using a private method to show that drop context menu.

    >what are you using to validate formats?
    I have a small custom tool here for that. I can mail it to you if you like.

  11. #11

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

    Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro

    So I'm not seeing FileGroupDescriptorW with that tool either, but neither do I see it when I drag straight from Explorer. Weird.. is it important enough to obsess over?

    And for the cursor, have you tried the SetCursor API?

  12. #12
    Member
    Join Date
    Jan 2015
    Posts
    40

    Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro

    FileGroupDescriptorW: That's weird indeed. Might depend on Windows version? (Win 8.1 here)

    SetCursor API: Good idea, I tried it but the best I could achieve was an ultra-fast flicker between two mousepointers (mine and theirs). Well, not so important at the moment.

  13. #13

  14. #14

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

    Re: [VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDro

    I've done a little work on drag images... here's how to use IDragSourceHelper (included in the 2015/6/11 oleexp) to create a custom drag image with a 32x32 file icon. Although this makes the description text disappear... on XP you're out of luck, but Vista+ lets us switch to IDragSourceHelper2 where you have the option to make it appear (i've been trying to customize that text via DropDescription as an hGloblal add without much luck).

    With your already fully initialized IDataObject (just before SHDoDragDrop),
    Code:
                Dim idsh As IDragSourceHelper2
                Set idsh = New DragDropHelper
    
                If idsh Is Nothing Then
                    Debug.Print "Failed to create idropsourcehelper"
                    Exit Function
                End If
                
                Dim sdi As SHDRAGIMAGE
                Call CreateDragImageForIDSH(sSelFullPath(0), sdi) 'note: change to your own file path source
                If sdi.hbmpDragImage = 0 Then
                    Debug.Print "Failed to create drag image"
                    Exit Function
                End If
                idsh.SetFlags DSH_ALLOWDROPDESCRIPTIONTEXT 'will not be there if not set like this
                idsh.InitializeFromBitmap sdi, iData
                Call DeleteObject(sdi.hbmpDragImage)
    And this example create drag image gets the icon... you can draw whatever you want here.. but from here on out I think it's manual drawing, I've been over tons of examples and none of them show how to create explorer's drag image
    (original credit to Raymond Chen's Dragging A Shell Object post on Old New Thing, all I did was translate to VB)
    Code:
    Public Function CreateDragImageForIDSH(pszPath As String, psdi As SHDRAGIMAGE) As Long
    Dim sfi As SHFILEINFO
    Dim himl As Long
    
    himl = SHGetFileInfoW(StrPtr(pszPath), 0, VarPtr(sfi), Len(sfi), SHGFI_SYSICONINDEX)
      If himl Then 'if (himl) {
        Dim cx As Long, cy As Long 'int cx, cy;
        Call ImageList_GetIconSize(himl, cx, cy) 'ImageList_GetIconSize(himl, &cx, &cy);
        psdi.sizeDragImage.cx = cx
        psdi.sizeDragImage.cy = cy
        psdi.ptOffset.X = cx
        psdi.ptOffset.Y = cy
        psdi.crColorKey = CLR_NONE
        Dim hDC As Long
        hDC = CreateCompatibleDC(0&)
        If hDC Then 'if (hdc) {
            psdi.hbmpDragImage = CreateBitmap(cx, cy, 1, 32, ByVal 0&) 'psdi->hbmpDragImage = CreateBitmap(cx, cy, 1, 32, NULL);
            If psdi.hbmpDragImage Then 'if (psdi->hbmpDragImage) {
                Dim hbmPrev As Long
                'hbmPrev = SelectBitmap(hdc, psdi.hbmpDragImage)
                hbmPrev = SelectObject(hDC, psdi.hbmpDragImage)
                Call ImageList_Draw(himl, sfi.iIcon, hDC, 0, 0, ILD_NORMAL)
                'SelectBitmap(hdc, hbmPrev);
                Call SelectObject(hDC, hbmPrev)
            End If
          
          Call DeleteDC(hDC)
        End If
    End If
    CreateDragImageForIDSH = psdi.hbmpDragImage
    End Function
    and finally some support (SHDRAGIMAGE is also in new typelib)
    Code:
    Public Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
    Public Declare Function ImageList_GetIconSize Lib "comctl32.dll" (ByVal himl As Long, lpcx As Long, lpcy As Long) As Boolean
    Public Declare Function ImageList_Draw Lib "comctl32.dll" (ByVal himl As Long, ByVal i As Long, ByVal hdcDst As Long, ByVal X As Long, ByVal Y As Long, ByVal fStyle As IL_DrawStyle) As Boolean
    Private Const CLR_NONE = &HFFFFFFFF
    Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
    Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Public Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
    Public Declare Function SHGetFileInfoW Lib "shell32" (ByVal pszPath As Long, ByVal dwFileAttributes As Long, ByVal psfi As Long, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
    Public Type SHFILEINFO   ' shfi
      hIcon As Long
      iIcon As Long
      dwAttributes As Long
      szDisplayName As String * MAX_PATH
      szTypeName As String * 80
    End Type
    Public Const SHGFI_SYSICONINDEX = &H4000 
    
    Public Sub DEFINE_UUID(Name As UUID, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
      With Name
        .Data1 = L
        .Data2 = w1
        .Data3 = w2
        .Data4(0) = B0
        .Data4(1) = b1
        .Data4(2) = b2
        .Data4(3) = B3
        .Data4(4) = b4
        .Data4(5) = b5
        .Data4(6) = b6
        .Data4(7) = b7
      End With
    End Sub
    Public Function IID_IDragSourceHelper() As UUID
    '{de5bf786-477a-11d2-839d-00c04fd918d0}
    Static iid As UUID
     If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &HDE5BF786, CInt(&H477A), CInt(&H11D2), &H83, &H9D, &H0, &HC0, &H4F, &HD9, &H18, &HD0)
      IID_IDragSourceHelper = iid
      
    End Function
    
    Public Function IID_IDragSourceHelper2() As UUID
    '{83E07D0D-0C5F-4163-BF1A-60B274051E40}"
    Static iid As UUID
     If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H83E07D0D, CInt(&HC5F), CInt(&H4163), &HBF, &H1A, &H60, &HB2, &H74, &H5, &H1E, &H40)
      IID_IDragSourceHelper2 = iid
      
    End Function

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