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

 

[traveler4]

Thank you @Jaafar Tribak for your perseverance.

What happens, is the above B): when I drag&drop a file which exceeds the 259-char-limit from the network drive, then I get the run-time error at ReDim sFileNames(lFilesCount - 1) (because lFilesCount=0), so I never get into the For-Loop:

Even when I skip the ReDim line of code and step into the For-Loop and execute SysReAllocStringLen(), sShortPathName remains empty (""). I guess, the problem is that tStg.pData is a Nullptr:

Kind regards.

 

[Jaafar Tribak]

It seems that DragQueryFile is not working as expected for those specific network drive files.

Place a Debug.Print before the function as follows and see what value you get for tStg.pData

Debug.Print tStg.pData
lFilesCount = DragQueryFileW(tStg.pData, &HFFFFFFFF, 0, 0)

 

[traveler4]

The Debug.Print outputs 0. The screenshot also shows the values of the other elements of tStg. I'm on 64bit (Win and MSOfice/Excel).

 

[MountainMain]

I do not believe the issue is VBA or Excel. You cannot drag-n-drop pathnames over MAX_CHARS (260 characters) in Windows Explorer or Directory Opus in or out jut like you can't in Jaafar's code. I am almost certain it is a limitation in Shell32, which is the underlying code behind Explorer and almost all Windows programs since about 2000. Anything that uses Shell has this limit. Microsoft has caught a lot of grief about this over the years but never fixed Shell32. If you look on MSDN you will see that in Windows 10+ there is a user-registry modification that makes it easier to use paths longer than 260 character with some of the early NT-type functions but that doesn't extend to any of the Shell functions. For copy, move, rename and delete operations it is very popular to use the API function SHFileOperation which is in Shell32.dll. It comes in an ANSI and a Unicode version but each is limited to MAX_PATH. BTW, this is the only function I know of that enables you to delete a file to the Recycle Bin (means also that you cannot delete a file to the Recycle Bin with a path longer than MAX_PATH length).

If you want to shell out to a new process, a popular way of doing that is with the API function ShellExecuteEx, also found in Shell32.dll and also limited to MAX_PATH. The advantage of this function versus CreateProcess (in kernel32.dll and can handle Unicode paths up to 32,767 characters) is that it is the only way to start a program with elevated privileges and an elevation prompt.

There are ways to get around the MAX_PATH limit by using functions not in Shell32.dll but I don't know of another way to do the Drag-n-Drop. To my knowledge you can't do that in Drag-n-Drop since it appears it ties into Shell32 "behind the scenes". For example, if you drag one or more file names to Jaafar's drop target from Windows Explorer, I am fairly certain Explorer use Shell32 and the MAX_PATH limit occurs with the drag from Explorer so when Explorer sees the extra long pathname it just refuses to copy the pathname to anywhere, including Jaafar's drop code. That when you drag one extra long pathname file and drop it on Jaafar's drop target it shows the count of files dropped = 0.

 

[Jaafar Tribak]

@traveler4

What about if you apply he code in post#15 (ie: The non- lightweight interface approach) to those long network file paths ? Does the problem also happen ?

 

[MountainMain]

Jaafar,

I normally use Excel 2010 and Excel 365, both as 64-bit. However, I have to support all the way back to 32-bit Excel XP. So I run everything I work on through this version running in Oracle VirtualBox. I couldn't get your code to work and I had to make a modifications to your single ListBox code to get it to work.

In your function "Drop" for the 32-bit version you need to change "pDataObj As Long" to "ByVal pDataObj As IUnknown" to match the 64-bit declaration.

With that change it works as it should in 32-bit Excel.

 

[Jaafar Tribak]

Jaafar,

I normally use Excel 2010 and Excel 365, both as 64-bit. However, I have to support all the way back to 32-bit Excel XP. So I run everything I work on through this version running in Oracle VirtualBox. I couldn't get your code to work and I had to make a modifications to your single ListBox code to get it to work.

In your function "Drop" for the 32-bit version you need to change "pDataObj As Long" to "ByVal pDataObj As IUnknown" to match the 64-bit declaration.

With that change it works as it should in 32-bit Excel.

Thanks for testing in x32bit and letting us know

That was one of those annoying errors that often go unnoticed when writing bitness-dependent code without testing.

The x64bit section was correct (ByVal pDataObj As IUnknown) but I somehow forgot to do the same in the x32 part. I probably got carried away by the p letter in pDataObj suggesting a x32 Pointer address (Long).

#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

In fact, speaking of pointers, DispCallFunc expects to be passed a pointer in its first *pvInstance argument. This means that the following will also work if we were to leave ByVal pDataObj As Long:

hRes = CallDispFuncCOM(pDataObj, 3 * PTR_LEN, vbLong, CC_STDCALL, VarPtr(tFmtc), VarPtr(tStg))

Notice that I only removed ObjPtr(pDataObj)

 

[Jaafar Tribak]

Hi,

In this post, I am showing a new version which doesn't use the DragQueyFileW at all . Instead, It uses the IEnumFORMATETC, IShellItemArray, IEnumShellItems and IShellItem Interfaces in order to retrieve the list of the Shell items being dragged and dropped.

I hope this new method works for you traveler4 without issues.

Workbook Example
ShellDragNDrop MultipleListBoxes_IShellItemArray_Version_.xlsm


New API 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 DRAG_DROP
    #If Win64 Then
        pVtable As LongLong
        Func(6) As LongLong
        hwnd As LongLong
    #Else
        pVtable As Long
        Func(6) As Long
        hwnd As Long
    #End If
    RefCount As Long
End Type

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

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type


#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongLong
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongLong)
    #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
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint 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 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
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetLongPathNameW Lib "kernel32" (ByVal lpszShortPath As LongPtr, ByVal lpszLongPath As LongPtr, ByVal cchBuffer As Long) As Long
    Private Declare PtrSafe Function PathIsNetworkPathW Lib "shlwapi" (ByVal pszPath As LongPtr) As Long
    Private Declare PtrSafe Function PathIsUNCW Lib "shlwapi" (ByVal pszPath As LongPtr) As Long
    Private Declare PtrSafe Function SHCreateShellItemArrayFromDataObject Lib "shell32" (ByVal pdo As LongPtr, riid As Any, ppv As Any) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function SysReAllocString Lib "oleAut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr) ' Frees memory allocated by the shell
#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 WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint 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 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
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function GetLongPathNameW Lib "kernel32" (ByVal lpszShortPath As Long, ByVal lpszLongPath As Long, ByVal cchBuffer As Long) As Long
    Private Declare Function PathIsNetworkPathW Lib "shlwapi" (ByVal pszPath As Long) As Long
    Private Declare Function PathIsUNCW Lib "shlwapi" (ByVal pszPath As Long) As Long
    Private Declare Function SHCreateShellItemArrayFromDataObject Lib "shell32" (ByVal pdo As Long, riid As Any, ppv As Any) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) 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
#End If

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




'____________________________________________________ PUBLIC SUBS _______________________________________________________

Public Sub EnableDragAndDrop( _
        ByVal DropTargetObject As Object, _
        Optional ByVal PublicEventHandlerName As String, _
        Optional bEnableDrop As Boolean = True _
    )

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

    Call SetControlFocus(DropTargetObject)
    Call IUnknown_GetWindow(DropTargetObject, VarPtr(hwnd))
    If bEnableDrop Then
        sPublicEventHandlerName = PublicEventHandlerName
        Set oForm = GetParentForm(DropTargetObject)
        Call AddMinimizeMenu(oForm)
        Call AddToRemoveFromCollection(DropTargetObject)
        If Len(PublicEventHandlerName) = 0 Then Exit Sub
        If IsWindow(hwnd) Then
            With tDragDrop
                .pVtable = VarPtr(.Func(0))
                .hwnd = hwnd
                #If Win64 Then
                    .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
                    .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 RevokeDragDrop(.hwnd)
                Call RegisterDragDrop(.hwnd, VarPtr(.pVtable))
                Call DragAcceptFiles(.hwnd, True)
            End With
        End If
    Else
        Call RevokeDragDrop(hwnd)
        Call AddToRemoveFromCollection(DropTargetObject, False)
    End If
         
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
  This.RefCount = This.RefCount + 1
  AddRef = This.RefCount
End Function

Private Function Release(This As DRAG_DROP) As Long
  This.RefCount = This.RefCount - 1
  Release = This.RefCount
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 LongLong, _
        ByVal KeyState As Long, _
        ByVal pt As LongLong, _
        ByRef pdwEffect As Long _
    ) As Long
   
    Const PTR_SIZE = 8
   
    Dim pI****emArray As LongLong     'IShellItemArray
    Dim pIEnumShellItems As LongLong  'IEnumShellItems
    Dim pIShellItem  As LongLong      'IShellItem
    Dim lpFile As LongLong
    Dim pcl As LongLong
    Dim Ptr As LongLong, hWinFromPt As LongLong

#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_SIZE = 4
   
    Dim pI****emArray As Long     'IShellItemArray
    Dim pIEnumShellItems As Long  'IEnumShellItems
    Dim pIShellItem  As Long      'IShellItem
    Dim lpFile As Long
    Dim pcl As Long
    Dim hWinFromPt As Long

#End If

    Const CC_STDCALL = 4
    Const CF_HDROP = 15
    Const SM_CXVSCROLL = 2
    Const SM_CXHTHUMB = 10
    Const S_OK = 0&
    Const SIGDN_FILESYSPATH = &H80058000
    Const IShellItemArray = "{b63ea76d-1f85-456f-a19c-48159efa858b}"


    Dim uGUID(0 To 3) As Long
    Dim tTextRect As RECT, XOffset As Long
    Dim sFileNames() As String, KeyStates As Integer
    Dim hRes As Long, lFilesCount As Long, i As Long
    Dim sShortPathName As String, sLongPathName As String, Ret As Long
    Dim oCurrentDropObject As Object

    #If Win64 Then
        Call CopyMemory(Ptr, pt, LenB(pt))
        hWinFromPt = WindowFromPoint(Ptr)
    #Else
        hWinFromPt = WindowFromPoint(X, Y)
    #End If

    If QueryDataObject(pDataObj, CF_HDROP) Then
   
        Call IIDFromString(StrPtr(IShellItemArray), VarPtr(uGUID(0)))
        Call SHCreateShellItemArrayFromDataObject(pDataObj, uGUID(0), pI****emArray)
        If pI****emArray Then
            'IShellItemArray::EnumItems
            Call CallDispFuncCOM(pI****emArray, 9 * PTR_SIZE, vbLong, CC_STDCALL, VarPtr(pIEnumShellItems))
            'IEnumShellItems::Next
            Do While CallDispFuncCOM(pIEnumShellItems, 3 * PTR_SIZE, vbLong, CC_STDCALL, 1&, VarPtr(pIShellItem), VarPtr(pcl)) = S_OK
                'IShellItem::GetDisplayName
                Call CallDispFuncCOM(pIShellItem, 5 * PTR_SIZE, vbLong, CC_STDCALL, SIGDN_FILESYSPATH, VarPtr(lpFile))
                'IShellItem::Release
                Call CallDispFuncCOM(pIShellItem, 2 * PTR_SIZE, vbLong, CC_STDCALL)
                ReDim Preserve sFileNames(lFilesCount)
                sFileNames(lFilesCount) = GetStrFromPtrW(lpFile)
                lFilesCount = lFilesCount + 1
            Loop
        End If
   
        'XOffset may need adjusting dependng on the Listbox Font.
        XOffset = 2 * GetSystemMetrics(SM_CXVSCROLL) + 2 * GetSystemMetrics(SM_CXHTHUMB)
        For i = LBound(sFileNames) To UBound(sFileNames)
            sShortPathName = sFileNames(i)
            Ret = GetLongPathNameW(StrPtr(sShortPathName), StrPtr(""), 0)
            sLongPathName = String(Ret, vbNullChar)
            Ret = GetLongPathNameW(StrPtr(sShortPathName), StrPtr(sLongPathName), Ret)
            sLongPathName = Left(sLongPathName, Ret)
            sFileNames(i) = sLongPathName
            Set oCurrentDropObject = DropTargetCollection(CStr(hWinFromPt))
            If Not oCurrentDropObject Is Nothing And TypeOf oCurrentDropObject Is MSForms.ListBox Then
                With oCurrentDropObject
                    tTextRect = GetTextRect(oCurrentDropObject, sFileNames(i))
                    If Len(.Tag) = 0 Then
                        .Tag = 0
                    End If
                    If CSng(.Tag) < tTextRect.Right - tTextRect.Left Then
                        .Tag = PXtoPT((tTextRect.Right - tTextRect.Left) + XOffset, False) * 100 / oForm.Zoom
                    End If
                End With
            End If
        Next
        KeyStates = KeyState
       
        If TypeOf oCurrentDropObject Is MSForms.ListBox Then
            oCurrentDropObject.ColumnWidths = oCurrentDropObject.Tag
        End If
        Call OnDrop(oCurrentDropObject, sFileNames, KeyStates)
       
    End If
   
End Function



'____________________________________________________ Helper Routines ____________________________________________________

#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

#If Win64 Then
    Private Function QueryDataObject(pDataObject As LongLong, DataFormat As Long) As Boolean
        Const PTR_SIZE = 8
        Dim pEnumFORMATETC As LongLong 'IEnumFORMATETC
#Else
    Private Function QueryDataObject(pDataObject As Long, DataFormat As Long) As Boolean
        Const PTR_SIZE = 4
        Dim pEnumFORMATETC As Long 'IEnumFORMATETC
#End If
 
    Const CC_STDCALL = 4
    Const S_OK = 0&
    Const CF_HDROP = 15
    Const DATADIR_GET = 1
   
    Dim tFMTETC As FORMATETC

    'IDataObject::EnumFormatEtc
    If CallDispFuncCOM(pDataObject, 8 * PTR_SIZE, vbLong, CC_STDCALL, DATADIR_GET, VarPtr(pEnumFORMATETC)) = S_OK Then
    'IEnumFORMATETC::Next
    Do While CallDispFuncCOM(pEnumFORMATETC, 3 * PTR_SIZE, vbLong, CC_STDCALL, 1&, VarPtr(tFMTETC), 0&) = S_OK
        If tFMTETC.cfFormat = CF_HDROP Then
            QueryDataObject = True: Exit Function
        End If
    Loop
    End If

End Function

#If Win64 Then
    Private Function GetStrFromPtrW(ByVal Ptr As LongLong) As String
#Else
    Private Function GetStrFromPtrW(ByVal Ptr As Long) As String
#End If

    Call SysReAllocString(VarPtr(GetStrFromPtrW), Ptr)
    Call CoTaskMemFree(Ptr)
End Function

Private Function GetParentForm(ByVal obj As Object) As Object
    Do While TypeOf obj Is MSForms.Control
        Set obj = obj.Parent
    Loop
    Set GetParentForm = obj
End Function

Private Sub SetControlFocus(ByVal obj As Object)
    On Error Resume Next
    CallByName obj, "SetFocus", VbMethod
End Sub

Private Sub AddToRemoveFromCollection(ByVal DropTarget As Object, Optional ByVal bAdd As Boolean = True)
   
    On Error Resume Next
   
    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If
   
    Call IUnknown_GetWindow(DropTarget, VarPtr(hwnd))
   
    If DropTargetCollection Is Nothing Then
        Set DropTargetCollection = New Collection
    End If
   
    If bAdd Then
        DropTargetCollection.Add DropTarget, CStr(hwnd)
    Else
        DropTargetCollection.Remove CStr(hwnd)
    End If
 
    If DropTargetCollection.Count = 0 Then
        Set DropTargetCollection = Nothing
    End If
   
End Sub

Private Sub OnDrop(ByVal TargetObject As Object, FileNames() As String, ByVal KeyStates As Integer)
    Dim i As Long
    On Error Resume Next
    For i = LBound(FileNames) To UBound(FileNames)
        CallByName oForm, sPublicEventHandlerName, VbMethod, TargetObject, FileNames(i), KeyStates
        If Err.Number = 438 Then
        On Error GoTo 0
          Err.Raise Number:=vbObjectError + 438, _
            Description:="Can't find the Pseudo-Event Handler associated with " & TargetObject.Name & "." & vbNewLine & _
            vbNewLine & "Please, check that the name of the Public Psseudo-Event handler located in the userform is correct."
        End If
    Next i
End Sub

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 Function GetTextRect(ByVal DropTarget As Object, ByVal sText As String) As RECT
    Const DT_CALCRECT = &H400
   
    #If Win64 Then
        Dim hwnd As LongLong, hdc As LongLong, hPrevFont As LongLong
    #Else
        Dim hwnd As Long, hdc As Long, hPrevFont As Long
    #End If
   
    Dim tTextRect As RECT, IFont As stdole.IFont
   
    Call IUnknown_GetWindow(DropTarget, VarPtr(hwnd))
    hdc = GetDC(hwnd)
    On Error Resume Next
        Set IFont = CallByName(DropTarget, "Font", VbGet)
    On Error GoTo 0
    If Not IFont Is Nothing Then
        hPrevFont = SelectObject(hdc, IFont.hFont)
        Call DrawText(hdc, sText, Len(sText), tTextRect, DT_CALCRECT)
        Call SelectObject(hdc, hPrevFont)
        Call DeleteObject(hPrevFont)
    End If
   
    Call ReleaseDC(hwnd, hdc)
    tTextRect.Right = tTextRect.Right + 20
    GetTextRect = tTextRect
End Function

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    Static lDPI(1), hdc

    If lDPI(0) = 0 Then
        hdc = GetDC(0)
        lDPI(0) = GetDeviceCaps(hdc, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(hdc, LOGPIXELSY)
        hdc = ReleaseDC(0, hdc)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PXtoPT(ByVal Pixels As Single, ByVal bVert As Boolean) As Single
    Const POINTSPERINCH As Long = 72
    PXtoPT = (Pixels / (ScreenDPI(bVert) / POINTSPERINCH))
End Function

The client UserForm code stays the same.

regards.

 

[traveler4]

Dear @Jaafar Tribak ,
sorry and apologies - somehow I had overlooked your post for almost three months. Thank you for the code.

I have checked it against the following cases (see also screenshot):
A) Drag&Drop from Local Disk with NTFS: works correctly, short and long paths
B) Drag&Drop from USB Stick with exFAT: works correctly for short paths, long paths have additional characters \\?\ at the beginning
C) Drag&Drop from mapped Network Drive: works correctly for short paths, long paths have additional characters \\?\ at the beginning
It is easy, of course, to strip off the additional characters from the beginning, but just to let you know.

So yes, this other approach does support very long path names! Thanks a lot for your efforts and this nice solution .

 

[Jaafar Tribak]

Dear @Jaafar Tribak ,
sorry and apologies - somehow I had overlooked your post for almost three months. Thank you for the code.

No worries ... it happens to me alot with many forum threads LOL