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, your fantastic magic works like a charm!

 

[Jaafar Tribak]

FYI, I just corrected a small but stupid mistake in the code published in post#30 . (The mistake was in the OnDrop routine in the api bas module).

So this code line:
CallByName oForm, "OnFileDrop", VbMethod, FileNames(i), KeyStates(i)
should become :
CallByName oForm, sPublicEventHandlerName, VbMethod, FileNames(i), KeyStates(i)

 

[traveler4]

Thanks @Jaafar Tribak for the correction.

Just for information (not really an issue for me): I found that when one drops something which includes at least one file where len(path+name+suffix) > 254, then the drop event does not fire (not even if the first and last filenames are short enough) and the functionality is broken until re-initialisation. I checked with two other applications which support DragNDrop and found:
- Notepad++ also ignores the drop if it contains too long fullnames. However the functionality is not broken for future drops.
- Outlook's email editor accepts the files and correctly includes them as attachments into the email editor.

 

[MountainMain]

In your standard module code, you have a Private Object variable "oForm" which you use as part of CallByName procedure called in OnDrop. Unfortunately there is no mechanism in EnableDragDrop to check to see if it has already been Set. You might want to put "If Not oForm Is Nothing Then Set oForm = Form" to prevent an error when EnabeDragDrop is called a 2nd time.

Also, there is no mechanism for getting rid of the oForm Set. Maybe you could kill 2 birds with one stone by setting oForm = Nothing in DisableDragDrop which would take care of the potential memory leak and also negate the need for the suggestion I made above.

 

[Jaafar Tribak]

@MountainMain
Good point. Thanks for the feedback.

There is another (more structural) issue that I discovered last night. The code doesn't work with more than one ListBox at a time. This is because of the code design and also because of an odd thing about ListBoxes in MSForms: They don't acquire a HWND until they get the focus !

BTW, I thought about placing the code in a Class so that each ListBox + variables would keep their own memory space but then I decided to keep everything in the bas module mainly because of the AddressOf statement . This, IMO, will result in less code.

Anyway, I am almost finished writing the new code that works with several Listboxes. I will post it when done.

Again thanks for the feedback.

 

[Jaafar Tribak]

Thanks @Jaafar Tribak for the correction.

Just for information (not really an issue for me): I found that when one drops something which includes at least one file where len(path+name+suffix) > 254, then the drop event does not fire

Hi traveler4

Thanks for the follow up.

I did not experience the issue you describe. Anyways, I have now updated the code so that it will also work with more tha one ListBox . Also, I now will be using GetLongPathNameW + longer string buffers so, hopefully, this will probably remedy the above issue you are experiencing.

 

[Jaafar Tribak]

Ok. Here is the new code for multiple ListBoxes.




ShellDragNDropMultipleListBoxes.xlsm

@traveler4 The Listboxes adjust their ColumnWidth automatically + display their horizontal scrollbar in order to accomodate and see the widest entry. This part of the code might need some adjustment though specially if using too small or too large fonts . Also, this code should, in theory register, as shell DragNDrop target any windowed control inside the userform (not only ListBoxes) such as Frames and Multipages as well as the UserForm itself and its client area.

Any feedback is most welcome.

1- 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 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
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 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
    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 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
#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 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
    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 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
#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
                    .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 RevokeDragDrop(.hwnd)
                Call RegisterDragDrop(.hwnd, VarPtr(.pVtable))
                Call DragAcceptFiles(.hwnd, True)
            End With
        End If
    Else
        Call AddToRemoveFromCollection(DropTargetObject, False)
        Call RevokeDragDrop(hwnd)
    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
'
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
    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_LEN = 4
    Dim hWinFromPt As Long
#End If

    Const CC_STDCALL = 4
    Const CF_HDROP = 15
    Const SM_CXVSCROLL = 2
    Const SM_CXHTHUMB = 10

    Dim uGUID(0 To 3) As Long
    Dim tFmtc As FORMATETC
    Dim tStg As STGMEDIUM
    Dim tTextRect As RECT, XOffset As Long
    Dim sFileNames() As String, KeyStates() As Integer
    Dim hRes As Long, lFilesCount As Long, sBuffer As String, i As Long
    Dim sShortPathName As String, sLongPathName As String, Ret As Long
    Dim oCurrentListBox As Object

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

    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)
    'XOffset may need adjusting dependng on the Listbox Font.
    XOffset = 2 * GetSystemMetrics(SM_CXVSCROLL) + 2 * GetSystemMetrics(SM_CXHTHUMB)
   
    For i = 0 To lFilesCount - 1
        sShortPathName = Space(1024) & vbNullChar
        Ret = DragQueryFileW(tStg.pData, i, StrPtr(sShortPathName), Len(sShortPathName))
        sShortPathName = Left(sShortPathName, Ret)
        sLongPathName = Space(1024) & vbNullChar
        Ret = GetLongPathNameW(StrPtr(sShortPathName), StrPtr(sLongPathName), Len(sLongPathName))
        sFileNames(i) = Left(sLongPathName, Ret)
        KeyStates(i) = KeyState
        Set oCurrentListBox = DropTargetCollection(CStr(hWinFromPt))
        If Not oCurrentListBox Is Nothing Then
            With oCurrentListBox
                tTextRect = GetTextRect(oCurrentListBox, Left(sLongPathName, Ret))
                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
   
    oCurrentListBox.ColumnWidths = oCurrentListBox.Tag
    Call OnDrop(oCurrentListBox, sFileNames, KeyStates)
    Call ReleaseStgMedium(tStg)
   
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

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)
    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If
   
    On Error Resume Next
   
    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
        Debug.Print "all cleared."
        Set DropTargetCollection = Nothing
    End If
End Sub

Private Sub OnDrop(ByVal TargetObject As Object, FileNames() As String, 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(i)
        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)
    Set IFont = DropTarget.Font
    hPrevFont = SelectObject(hdc, IFont.hFont)
    Call DrawText(hdc, sText, Len(sText), tTextRect, DT_CALCRECT)
    Call SelectObject(hdc, IFont.hFont)
    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

2- UserForm Code example: (As per the workbook demo)

Option Explicit


Private Sub UserForm_Initialize()
    Call EnableDragAndDrop(ListBox1, PublicEventHandlerName:="OnFileDrop")
    Call EnableDragAndDrop(ListBox2, PublicEventHandlerName:="OnFileDrop")
    Call EnableDragAndDrop(ListBox3, PublicEventHandlerName:="OnFileDrop")
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call EnableDragAndDrop(ListBox1, , bEnableDrop:=False)
    Call EnableDragAndDrop(ListBox2, , bEnableDrop:=False)
    Call EnableDragAndDrop(ListBox3, , bEnableDrop:=False)
End Sub


'________________________________________File Drop Event Hnadler__________________________________________

Public Sub OnFileDrop(ByVal TargetObj As Object, ByVal FilePathName As String, ByVal KeyState As Integer)
    TargetObj.AddItem FilePathName
    Label4.Caption = KeyState
End Sub

 

[MountainMain]

I have a file manager I have been working for VB6 and a similar one for VBA. I have been wanting a good way to drop files in VBA and this looks like the best I have seen (or done on my own) so far. I have 2 things: 1) in my note above I had "Not" in the test to see if oForm was Set. The "Not" should not be there. 2) I have been modifying your code to work with my file manager and I have a concern that yuo may want to address. You don't have any code to make the dialog box go away if the user switches worksheets. If normally you are catching the dropped file paths and then doing something with them (like in a file manager) then what you do on one sheet might not be what you do on another sheet and in fact, on th eother sheet yuo may not want to do anything at all. I played with this and with a Modal box it is easy since you can't do any worksheet changing while the dialog box is shown. However, this is not true for modeless forms. The only workable solution I could come up with was to put some code in ThisWorkbook for Workbook_SheetActivate where I ocmpare the new activated sheet name to the one I save in a Public variable in the standard module when i first showed the UserForm and if they differ I unload the form. I'll show my cod below>

Also, you need some code to get rid of the form and the API calls to make the ListBox be a drop target if someone ets Excel while the UserForm is showing. Also in ThisWorkbook I put some code ni Workbook_BeforeClose to get rid of the UserForm if it is loaded.

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If IsDropFormActive Then Unload DropTarget2
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
On Error Resume Next
If IsDropFormActive Then
   If StrComp(Sh.Name, myDropWS.Name, vbBinaryCompare) <> 0 Then
      Unload DropTarget2
      End If
   End If
End Sub

I defined IsDropFormActive as True when the UserForm initializes and False when it is unoaded. I also define myDropWS as the Activesheet when the UserForm is loaded and Nothing when the UserForm is unloaded.

 

[MountainMain]

My bad. The Workbook_SheetActivate Sub should look like this:

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim i As Long
On Error Resume Next
If IsDropFormActive Then
   i = StrComp(Sh.Name, myDropWS.Name, vbBinaryCompare)
   If i <> 0 Then
      Unload DropTarget2
      End If
   End If
End Sub

so that the On Error Resume Next works correctly. Sorry 'bout that.

 

[Jaafar Tribak]

My bad. The Workbook_SheetActivate Sub should look like this:

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim i As Long
On Error Resume Next
If IsDropFormActive Then
   i = StrComp(Sh.Name, myDropWS.Name, vbBinaryCompare)
   If i <> 0 Then
      Unload DropTarget2
      End If
   End If
End Sub

so that the On Error Resume Next works correctly. Sorry 'bout that.

So I guess, you are saying the Workbook_SheetActivate worked for you in the end to unload the form when activating another sheet . Cool.

Also, you need some code to get rid of the form and the API calls to make the ListBox be a drop target if someone ets Excel while the UserForm is showing. Also in ThisWorkbook I put some code ni Workbook_BeforeClose to get rid of the UserForm if it is loaded.

If you are using the code in post#30 then you will notice that I added a routine at the bottom of the module which essentially does what Workbook_BeforeClose does but in a standard module.

Private Sub Auto_Close()
    Call DisableDragAndDrop
End Sub

You could unload the Form from there too.