VBA Drag & Drop filepath

[jorispk]

Hi guys,

Yesterday I got some stuff working with dropping content from listbox to listbox.

No I'm trying to get a path from an external file, but I'm still not able to figure out a way to get the filepath...

This is what I have:

Private Sub test_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As Long, _
    ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
    Cancel = True
    Effect = 1
End Sub
Private Sub test_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As Long, ByVal Data As MSForms.DataObject, ByVal X As Single, _
    ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
    Cancel = True
    Effect = 1
    Dim MyDataObject As DataObject
    Set MyDataObject = New DataObject
    'MyDataObject = GetObject(Data.Files(1))
    Me.test = MyDataObject
End Sub

I thought maybe something as Data.Files(1) would work but it doesn't. The Drag and drop feature works fine though if I say for example Me.test = "check" than it becomes that after dragging the file.

Any suggestions how to get the filepath??

Thank you

 

[MountainMain]

Jaafar,

In your code for dropping filenames onto a ListBox you used something in a line that I have never seen before:

Me.ListBox1.[_GethWnd]

I looked all over for [_GethWnd] and found nothing. It is not defined in your code nor is it in the Object Browser, even when I show Hidden Members. It appears to be a ca to a function that returns the handle for the ListBox but where did this come from?

 

[Jaafar Tribak]

Jaafar,

In your code for dropping filenames onto a ListBox you used something in a line that I have never seen before:

Me.ListBox1.[_GethWnd]

I looked all over for [_GethWnd] and found nothing. It is not defined in your code nor is it in the Object Browser, even when I show Hidden Members. It appears to be a ca to a function that returns the handle for the ListBox but where did this come from?

It is a hidden member of the generic MsForms.Control Class.
Note that, not all controls support this Method... I think , only the ListBox, Multipage and Frame do.

 

[MountainMain]

Well, sure enough, there it is! Thanks. I learned something new today!

 

[audeser]

And if you want to get elements from list to clipboard...

From Jaafar last sample:

I have renamed list as lstExplorer and set some properties: ListStyle to fmListStyleOption and Multiselect to fmMultiSelectMulti. I have also added a "cmdCopyList" command button.
Then paste this code in userform code

Private Sub cmdCopyList_Click()
    Dim col As Long, row As Long
    Dim textItem As String
    Dim clipboardText  As String
    Dim clipboard As Object 'New MSForms.DataObject
    Set clipboard = CreateObject("new:{" & "1C3B4210-F441-11CE-B9EA-00AA006B1A69" & "}")   'this does not work: CreateObject("MSForms.DataObject")
    
    With lstExplorer
        If .ListIndex > -1 And .Selected(.ListIndex) Then ' check there is at least one item selected
            For row = 0 To .ListCount - 1
                If .Selected(row) Then '<--| if current row selected
                    For col = 0 To .ColumnCount - 1
                        textItem = vbNullString
                        On Error Resume Next ' Handles null values
                        textItem = .Column(col, row)
                        On Error GoTo 0
                        If col > 0 Then clipboardText = clipboardText & vbTab
                        clipboardText = clipboardText & textItem
                    Next col
                    If row < .ListCount - 1 Then clipboardText = clipboardText & vbNewLine
                End If
            Next row
        End If
    End With
    With clipboard
        .SetText clipboardText
        .PutInClipboard
    End With
End Sub

 

[jonoww]

Hello,

This is a great method, does anyone know how I could multiple file paths as strings? For example each file that is dragged into the List box is assigned to a separate string like File1, File2. And any possibility of limiting the number of files to be attached.

Thanks

 

[traveler4]

I have taken the example workbook from Jaafar's post #18 and changed the calling procedure from

Sub ShaowForm()
UserForm1.Show
End Sub

to

Sub ShaowForm()
UserForm1.Show (False)
End Sub

in order to make the form non-modal.

What then works is
- select cells with the mouse
- select menu items via mouse
- select menu items via Alt-keys
what partly works is
- select cells by mouse, assign a background colour: works but the cursor turns to hourglass until the next click
what not works is:
- use cursor keys to move selection to other cells
- enter text into selected cell

Any chance to get the non-working stuff working?

Background is: I would like to have the Drop-Userform linger around all the time while the user can work with Excel as usual. Only when he drops files onto the userform, special actions will take place.

I'm on Windows10 Pro 20H2 19042.1706 and Office 365 V2205 Build 16.0.15225.20172 64Bit.
Thanks.

 

[MountainMain]

traveler4,

My experience with Excel is that a modeless UserForm is not really that. I would like for it to be treated like Excel's Find dialog box which allows the user to do anything else while the box patiently sits there waiting for the user to use it. But instead it has the limitations you describe. I think that's just the way it works in Excel.

I have a modified version of Jaafar's code that is Unicode, 32/64 bit and with a few other bells & whistles. I would be glad to upload it but I can't figure out how to upload a zip or an Excel file in this forum.

 

[traveler4]

Thankyou, @MountainMain for the reply.

Please see this version of FileDragNDrop. It has a non-modal box which patiently sits there without interfering with the user's normal use of Excel. That's great. Not great is, that it recognises the drop events only unreliably: some drops trigger the event, others don't. It seems random, I have not been able to find out any regularity.

So, the reason for the behaviour described in post #26 is not the modeless UserForm per se. Rather, one of the functions which interact with the Messages seems to swallow certain messages other than WM_DROPFILES. Unfortunately, properly accessing the message queue is beyond my Windows knowledge.

Regarding uploads, it seems in deed that one cannot upload files in this forum. One can, however, upload files on box.com (free plan available) or any similar service and reference with a link. I'd appreciate seeing the "bells & whistles" in your modified version.

 

[Jaafar Tribak]

Thankyou, @MountainMain for the reply.

Please see this version of FileDragNDrop. It has a non-modal box which patiently sits there without interfering with the user's normal use of Excel. That's great. Not great is, that it recognises the drop events only unreliably: some drops trigger the event, others don't. It seems random, I have not been able to find out any regularity.

So, the reason for the behaviour described in post #26 is not the modeless UserForm per se. Rather, one of the functions which interact with the Messages seems to swallow certain messages other than WM_DROPFILES. Unfortunately, properly accessing the message queue is beyond my Windows knowledge.

Regarding uploads, it seems in deed that one cannot upload files in this forum. One can, however, upload files on box.com (free plan available) or any similar service and reference with a link. I'd appreciate seeing the "bells & whistles" in your modified version.

Thanks MountainMain.

WM_DROPFILES is a sent message so we can only intercept it via subclassing or via a GetMessage\PeekMessage loop . Subclassing can be make excel\vba unstable and if not careful it can crash the application... GetMessage is very restrictive and can even lock the User Interface not just when using Modeless userforms.

I am about to finish writing some code which doesn't use any of the above. It actually creates an IDropTarget object in memeory at runtime (no TLB dependencies- just plain vba). The code is rather complex but does seem to work smoothly for dragging and dropping shell items on any window (hwnd) of your choice... Tested on Modal as well as on Modeless userforms. So far so good.

I will post the entire code and a demo in a few minutes.

 

[Jaafar Tribak]

The code allows for dragging shell items (Files, folders, shortcuts) from windows explorer to the window of your choice. works with Modal as well as with Modeless forms without restricting or locking the UI.

Workbook Demo
ShellDragNDrop.xlsm

(optionally, the code adds a Minimize button to the userform menu. This can be useful if the user wants to get the modeless form out of the way and work with excel. The Pseudo-Event handler (OnFileDrop) is located in the UserForm Module for practicality . This pseudo-event must be declared PUBLIC so it can be seen by the API code in Standard Module.

Public Sub OnFileDrop(ByVal FileName As String, ByVal KeyState As Integer)
The KeyState argument tell the user which key was pressed ( CTRL, SHIFT etc)

Although the api code seems complex, the user won't need to worry about it. Just stick that code in a Standard Module and leave it untouched.
To use the code, just call EnableDragAndDrop and DisableDragAndDrop as needed from within the userform.

Ok. Here is the entire code.

1- Main Code in a Standard Module:

Option Explicit

Private Enum E_TYMED
    TYMED_NULL = 0
    TYMED_HGLOBAL = 1
    TYMED_FILE = 2
    TYMED_ISTREAM = 4
    TYMED_ISTORAGE = 8
    TYMED_GDI = 16
    TYMED_MFPICT = 32
    TYMED_ENHMF = 64
End Enum

Private Enum DVASPECT
    DVASPECT_CONTENT = 1
    DVASPECT_THUMBNAIL = 2
    DVASPECT_ICON = 4
    DVASPECT_DOCPRINT = 8
End Enum

Private Type FORMATETC
    cfFormat As Long
    #If Win64 Then
        ptd As LongLong
    #Else
        ptd As Long
    #End If
    dwAspect As DVASPECT
    lindex As Long
    tymed As E_TYMED
End Type


Private Type STGMEDIUM
    tymed As E_TYMED
    #If Win64 Then
        pData As LongLong
    #Else
        pData As Long
    #End If
    pUnkForRelease As Object
End Type

Private Type DRAG_DROP
    #If Win64 Then
        pVtable As LongLong
        Func(6) As LongLong
        hwnd As LongLong
        CallBackAddr As LongLong
    #Else
        pVtable As Long
        Func(6) As Long
        hwnd As Long
        CallBackAddr As Long
    #End If
    FilePath As String
    bFlag As Boolean
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
    #End If
    Private Declare PtrSafe Function RegisterDragDrop Lib "ole32" (ByVal hwnd As LongPtr, ByVal pDropTarget As LongPtr) As Long
    Private Declare PtrSafe Function RevokeDragDrop Lib "ole32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As LongPtr, ByVal fAccept As Long)
    Private Declare PtrSafe Function DragQueryFileW Lib "shell32.dll" (ByVal hDrop As LongPtr, ByVal iFile As Long, Optional ByVal lpszFile As LongPtr, Optional ByVal cch As Long) As Long
    Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long
    Private Declare PtrSafe Function ReleaseStgMedium Lib "ole32.dll" (pMedium As STGMEDIUM) As Long
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
#Else
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA " (ByVal hwnd As Long , ByVal nIndex As Long, ByVal dwNewLong As Long ) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function RegisterDragDrop Lib "ole32" (ByVal hwnd As Long, ByVal pDropTarget As Long) As Long
    Private Declare Function RevokeDragDrop Lib "ole32" (ByVal hwnd As Long) As Long
    Private Declare Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept 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 ReleaseStgMedium Lib "ole32.dll" (pMedium As STGMEDIUM) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
#End If


Private tDragDrop As DRAG_DROP
Private oForm As Object, sPublicEventHandlerName As String



'____________________________________________________ PUBLIC SUBS _______________________________________________________

#If Win64 Then
    Public Sub EnableDragAndDrop( _
        ByVal Form As Object, _
        ByVal hwnd As LongLong, _
        ByVal PublicEventHandlerName As String _
    )
#Else
    Public Sub EnableDragAndDrop( _
        ByVal Form As Object, _
        ByVal hwnd As Long, _
        ByVal PublicEventHandlerName As String _
    )
#End If

    If Len(PublicEventHandlerName) = 0 Then Exit Sub
    Set oForm = Form
    sPublicEventHandlerName = PublicEventHandlerName
   
    Call AddMinimizeMenu(Form)

    If IsWindow(hwnd) Then
        With tDragDrop
            .pVtable = VarPtr(.Func(0))
            .hwnd = hwnd
   
            #If Win64 Then
                .CallBackAddr = VBA.CLngLng(AddressOf OnDrop)
                .Func(0) = VBA.CLngLng(AddressOf QueryInterface)
                .Func(1) = VBA.CLngLng(AddressOf AddRef)
                .Func(2) = VBA.CLngLng(AddressOf Release)
                .Func(3) = VBA.CLngLng(AddressOf DragEnter)
                .Func(4) = VBA.CLngLng(AddressOf DragOver)
                .Func(5) = VBA.CLngLng(AddressOf DragLeave)
                .Func(6) = VBA.CLngLng(AddressOf Drop)
            #Else
                .CallBackAddr = VBA.CLng(AddressOf OnDrop)
                .Func(0) = VBA.CLng(AddressOf QueryInterface)
                .Func(1) = VBA.CLng(AddressOf AddRef)
                .Func(2) = VBA.CLng(AddressOf Release)
                .Func(3) = VBA.CLng(AddressOf DragEnter)
                .Func(4) = VBA.CLng(AddressOf DragOver)
                .Func(5) = VBA.CLng(AddressOf DragLeave)
                .Func(6) = VBA.CLng(AddressOf Drop)
            #End If
           
            Call RegisterDragDrop(.hwnd, VarPtr(.pVtable))
            Call DragAcceptFiles(.hwnd, True)
           
        End With
       
        If tDragDrop.bFlag = False Then
            Call DisableDragAndDrop
            tDragDrop.bFlag = True
            Call EnableDragAndDrop(Form, tDragDrop.hwnd, PublicEventHandlerName)
        End If

     End If
         
End Sub

Public Sub DisableDragAndDrop(Optional ByVal Dummy As Boolean)
    With tDragDrop
        If .hwnd Then
            .bFlag = False
            tDragDrop = tDragDrop
            RevokeDragDrop .hwnd
        End If
    End With
End Sub


'____________________________________________________ IDropTarget Funcs ____________________________________________________


#If Win64 Then
    Private Function QueryInterface(This As DRAG_DROP, ByVal riid As LongLong, ByRef pObj As LongLong) As Long
#Else
    Private Function QueryInterface(This As DRAG_DROP, ByVal riid As Long, ByRef pObj As Long) As Long
#End If

    Const E_NOINTERFACE = &H80004002
    QueryInterface = E_NOINTERFACE
End Function

Private Function AddRef(This As DRAG_DROP) As Long
'
End Function

Private Function Release(This As DRAG_DROP) As Long
'
End Function

#If Win64 Then
    Private Function DragEnter(This As DRAG_DROP, ByVal pDataObj As IUnknown, ByVal KeyState As Long, ByVal pt As LongLong, ByRef pdwEffect As Long) As Long
#Else
    Private Function DragEnter(This As DRAG_DROP, ByVal pDataObj As IUnknown, ByVal KeyState As Long, ByVal x As Long, ByVal y As Long, ByRef pdwEffect As Long) As Long
#End If
'
End Function

Private Function DragLeave(This As DRAG_DROP) As Long
'
End Function

#If Win64 Then
    Private Function DragOver(This As DRAG_DROP, ByVal KeyState As Long, ByVal pt As LongLong, ByRef pdwEffect As Long) As Long
#Else
    Private Function DragOver(This As DRAG_DROP, ByVal KeyState As Long, ByVal x As Long, ByVal y As Long, ByRef pdwEffect As Long) As Long
#End If
'
End Function

#If Win64 Then
    Private Function Drop( _
        This As DRAG_DROP, _
        ByVal pDataObj As IUnknown, _
        ByVal KeyState As Long, _
        ByVal pt As LongLong, _
        ByRef pdwEffect As Long _
    ) As Long
   
        Const PTR_LEN = 8
#Else
    Private Function Drop( _
        This As DRAG_DROP, _
        ByVal pDataObj As Long, _
        ByVal KeyState As Long, _
        ByVal x As Long, _
        ByVal y As Long, _
        ByRef pdwEffect As Long _
    ) As Long
   
        Const PTR_LEN = 4
#End If

    Const CC_STDCALL = 4
    Const CF_HDROP = 15

    Dim uGUID(0 To 3) As Long
    Dim tFmtc As FORMATETC
    Dim tStg As STGMEDIUM
   
    Dim sFileNames() As String, KeyStates() As Integer
    Dim hRes As Long, lFilesCount As Long, sBuffer As String, i As Long

    On Error GoTo err_Handler

    With tFmtc
        .cfFormat = CF_HDROP
        .ptd = 0
        .dwAspect = DVASPECT_CONTENT
        .lindex = -1
        .tymed = TYMED_HGLOBAL
    End With

    hRes = CallDispFuncCOM(ObjPtr(pDataObj), 3 * PTR_LEN, vbLong, CC_STDCALL, VarPtr(tFmtc), VarPtr(tStg))
   
    lFilesCount = DragQueryFileW(tStg.pData, &HFFFFFFFF, 0, 0)
    ReDim sFileNames(lFilesCount - 1)
    ReDim KeyStates(lFilesCount - 1)
    For i = 0 To lFilesCount - 1
        Call SysReAllocStringLen(VarPtr(sBuffer), , DragQueryFileW(tStg.pData, i))
        Call DragQueryFileW(tStg.pData, i, StrPtr(sBuffer), Len(sBuffer) + 1&)
        sFileNames(i) = sBuffer
        KeyStates(i) = KeyState
    Next
    Call OnDrop(sFileNames, KeyStates)
    Call ReleaseStgMedium(tStg)
   
    Exit Function
   
err_Handler:

    Call DisableDragAndDrop

End Function



'____________________________________________________ Helper Func ____________________________________________________

#If Win64 Then
 Private Function CallDispFuncCOM( _
        ByVal InterfacePointer As LongLong, _
        ByVal VTableOffset As Long, _
        ByVal FunctionReturnType As Long, _
        ByVal CallConvention As Long, _
        ParamArray FunctionParameters() As Variant _
    ) As Variant
   
        Dim vParamPtr() As LongLong
#Else
    Private Function CallDispFuncCOM( _
        ByVal InterfacePointer As Long, _
        ByVal VTableOffset As Long, _
        ByVal FunctionReturnType As Long, _
        ByVal CallConvention As Long, _
        ParamArray FunctionParameters() As Variant _
    ) As Variant
   
        Dim vParamPtr() As Long
#End If


    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function

    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0 To 0)
        ReDim vParamType(0 To 0)
    Else
        ReDim vParamPtr(0 To pCount - 1&)
        ReDim vParamType(0 To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, _
        FunctionReturnType, pCount, vParamType(0), vParamPtr(0), vRtn)

    If pIndex = 0& Then
        CallDispFuncCOM = vRtn
    Else
        Call SetLastError(pIndex)
    End If

End Function

Private Sub AddMinimizeMenu(ByVal Form As MSForms.UserForm, Optional ByVal bMin As Boolean = True)
    Const GWL_STYLE As Long = (-16)
    Const WS_MINIMIZEBOX = &H20000

    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If

    If bMin Then
        Call IUnknown_GetWindow(Form, VarPtr(hwnd))
        Call SetWindowLong(hwnd, GWL_STYLE, GetWindowLong(hwnd, GWL_STYLE) Or WS_MINIMIZEBOX)
        Call DrawMenuBar(hwnd)
    End If
End Sub

Private Sub OnDrop(FileNames() As String, KeyStates() As Integer)
    Dim i As Long
    For i = LBound(FileNames) To UBound(FileNames)
        CallByName oForm, "OnFileDrop", VbMethod, FileNames(i), KeyStates(i)
    Next i
End Sub

Private Sub Auto_Close()
    Call DisableDragAndDrop
End Sub

2- Implementation of the above code in the UserForm Module:

Option Explicit

Private bDragDropEnabled As Boolean

Private Sub UserForm_Initialize()
    If bDragDropEnabled = False Then
        bDragDropEnabled = True
        Call EnableDragAndDrop(Form:=Me, hwnd:=ListBox1.[_GethWnd], PublicEventHandlerName:="OnFileDrop")
    End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call DisableDragAndDrop
    bDragDropEnabled = False
End Sub

'________________________________________File Drop Event Hnadler__________________________________________

Public Sub OnFileDrop(ByVal FileName As String, ByVal KeyState As Integer)
    ListBox1.AddItem FileName & vbTab & "... KeyPressd: ||| " & KeyState
End Sub