VBA Drag & Drop filepath

J

jorispk

New Member
Joined
Dec 9, 2011
Messages
22
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:
Code: 
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
 
Sort by date Sort by votes
I haven't had much succes in the past using the DataObject .. I find it easier to use the windows API for this kind of thing

The following should get you the full filepathname of the file that is being dragged & dropped onto the listbox and will be added as a new item to the listbox :

Code in the userform module :
Code: 
Option Explicit

Private Type POINTAPI
  X As Long
  Y As Long
End Type
 
Private Type MSG
  hwnd As Long
  message As Long
  wParam As Long
  lParam As Long
  time As Long
  pt As POINTAPI
End Type
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)

Private Declare Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long)

Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" _
(ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long

Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" _
(lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long

Private Declare Function WaitMessage Lib "user32" () As Long
 
Private Const PM_NOYIELD = &H2
Private Const PM_REMOVE = &H1
Private Const WM_DROPFILES = &H233
Private bUnload As Boolean

Private Sub UserForm_Activate()
    Dim FileDropMessage As MSG
    Dim hDrop As Long
    Dim FileName As String * 256
    Dim ret As Long
    Dim hwnd As Long
    
    'get the listbox handle
    hwnd = FindWindow(vbNullString, Me.Caption)
    hwnd = FindWindowEx(hwnd, 0, vbNullString, vbNullString)
    hwnd = FindWindowEx(hwnd, 0, vbNullString, vbNullString)
    
    'make the listbox accept dropped file
    DragAcceptFiles hwnd, True
    
    bUnload = False
    Do
        'wait for a file to be dropped
        WaitMessage
        Call PeekMessage(FileDropMessage, 0, 0, 0, 0)
        'if file dropped on the listbox then retrieve the name of the dropped file
        If PeekMessage(FileDropMessage, hwnd, WM_DROPFILES, WM_DROPFILES, PM_REMOVE Or PM_NOYIELD) Then
            hDrop = FileDropMessage.wParam
            ret = DragQueryFile(hDrop, 0, FileName, Len(FileName))
            ListBox1.AddItem Left(FileName, ret)
            'Release memory
            DragFinish hDrop
        End If
        DoEvents
    Loop Until bUnload
End Sub

Private Sub UserForm_Terminate()
    'exit msg loop
    bUnload = True
End Sub

The above code assumes that there is only one listbox on the userform .. If more than one listbox then the code will require some tweeking using the DragQueryPoint API in order to target the correct listbox
 
Last edited:
Upvote 0
Jaafar Tribak said:
I haven't had much succes in the past using the DataObject .. I find it easier to use the windows API for this kind of thing

The following should get you the full filepathname of the file that is being dragged & dropped onto the listbox and will be added as a new item to the listbox :

Code in the userform module :
Code: 
Option Explicit

Private Type POINTAPI
  X As Long
  Y As Long
End Type
 
Private Type MSG
  hwnd As Long
  message As Long
  wParam As Long
  lParam As Long
  time As Long
  pt As POINTAPI
End Type
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)

Private Declare Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long)

Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" _
(ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long

Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" _
(lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long

Private Declare Function WaitMessage Lib "user32" () As Long
 
Private Const PM_NOYIELD = &H2
Private Const PM_REMOVE = &H1
Private Const WM_DROPFILES = &H233
Private bUnload As Boolean

Private Sub UserForm_Activate()
    Dim FileDropMessage As MSG
    Dim hDrop As Long
    Dim FileName As String * 256
    Dim ret As Long
    Dim hwnd As Long
    
    'get the listbox handle
    hwnd = FindWindow(vbNullString, Me.Caption)
    hwnd = FindWindowEx(hwnd, 0, vbNullString, vbNullString)
    hwnd = FindWindowEx(hwnd, 0, vbNullString, vbNullString)
    
    'make the listbox accept dropped file
    DragAcceptFiles hwnd, True
    
    bUnload = False
    Do
        'wait for a file to be dropped
        WaitMessage
        Call PeekMessage(FileDropMessage, 0, 0, 0, 0)
        'if file dropped on the listbox then retrieve the name of the dropped file
        If PeekMessage(FileDropMessage, hwnd, WM_DROPFILES, WM_DROPFILES, PM_REMOVE Or PM_NOYIELD) Then
            hDrop = FileDropMessage.wParam
            ret = DragQueryFile(hDrop, 0, FileName, Len(FileName))
            ListBox1.AddItem Left(FileName, ret)
            'Release memory
            DragFinish hDrop
        End If
        DoEvents
    Loop Until bUnload
End Sub

Private Sub UserForm_Terminate()
    'exit msg loop
    bUnload = True
End Sub

The above code assumes that there is only one listbox on the userform .. If more than one listbox then the code will require some tweeking using the DragQueryPoint API in order to target the correct listbox
Click to expand...

Hi All and sorry for coming back on this old post.
I am trying to use the code given by Jaafar but I get an error saying of compilation saying that the project must be updated for use on 64 bit systems. Then it says I have to review and update declare statements and then mark them with PtrSafe attribute... Well all this is above my league now. And google is not really helping ! :-(

Anyone has a solution to solve that? My ultimate goal is to have drag drop files from windows explorer to excel and excel would write down the name and path on a spreadsheet. One after the other as I will repeat that manually hundreds of times...

Thanks for your help.
 
Upvote 0
jbesclapez said:
Hi All and sorry for coming back on this old post.
I am trying to use the code given by Jaafar but I get an error saying of compilation saying that the project must be updated for use on 64 bit systems. Then it says I have to review and update declare statements and then mark them with PtrSafe attribute... Well all this is above my league now. And google is not really helping ! :-(

Anyone has a solution to solve that? My ultimate goal is to have drag drop files from windows explorer to excel and excel would write down the name and path on a spreadsheet. One after the other as I will repeat that manually hundreds of times...

Thanks for your help.
Click to expand...

The following should work for 32 and 64 bits :

Code in the userform module:
Code: 
Option Explicit

Private Type POINTAPI
  X As Long
  Y As Long
End Type
 
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Type MSG
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    End Type
    
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As LongPtr, ByVal fAccept As Long)
    Private Declare PtrSafe Sub DragFinish Lib "shell32.dll" (ByVal HDROP As LongPtr)
    Private Declare PtrSafe Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal HDROP As LongPtr, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private hwnd As LongPtr

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
    
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)
    Private Declare Sub DragFinish Lib "shell32.dll" (ByVal HDROP As Long)
    Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal HDROP As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private hwnd As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
 
Private Const PM_NOYIELD = &H2
Private Const PM_REMOVE = &H1
Private Const WM_DROPFILES = &H233
Private bUnload As Boolean

Private Sub UserForm_Activate()
    Dim FileDropMessage As MSG
    Dim HDROP As LongPtr
    Dim FileName As String * 256
    Dim ret As Long
    
    'get the listbox handle
    hwnd = FindWindow(vbNullString, Me.Caption)
    hwnd = FindWindowEx(hwnd, 0, vbNullString, vbNullString)
    hwnd = FindWindowEx(hwnd, 0, vbNullString, vbNullString)
    
    'make the listbox accept dropped file
    DragAcceptFiles hwnd, True
    
    bUnload = False
    Do
        'wait for a file to be dropped
        WaitMessage
        Call PeekMessage(FileDropMessage, 0, 0, 0, 0)
        'if file dropped on the listbox then retrieve the name of the dropped file
        If PeekMessage(FileDropMessage, hwnd, WM_DROPFILES, WM_DROPFILES, PM_REMOVE Or PM_NOYIELD) Then
            HDROP = FileDropMessage.wParam
            ret = DragQueryFile(HDROP, 0, FileName, Len(FileName))
            ListBox1.AddItem Left(FileName, ret)
            'Release memory
            DragFinish HDROP
        End If
        DoEvents
    Loop Until bUnload
End Sub

Private Sub UserForm_Terminate()
    'exit msg loop
    bUnload = True
End Sub
 
Upvote 0
Jaafar Tribak said:
The following should work for 32 and 64 bits :

Code in the userform module:
Code: 
Option Explicit

Private Type POINTAPI
  X As Long
  Y As Long
End Type
 
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Type MSG
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    End Type
    
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As LongPtr, ByVal fAccept As Long)
    Private Declare PtrSafe Sub DragFinish Lib "shell32.dll" (ByVal HDROP As LongPtr)
    Private Declare PtrSafe Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal HDROP As LongPtr, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private hwnd As LongPtr

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
    
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)
    Private Declare Sub DragFinish Lib "shell32.dll" (ByVal HDROP As Long)
    Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal HDROP As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private hwnd As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
 
Private Const PM_NOYIELD = &H2
Private Const PM_REMOVE = &H1
Private Const WM_DROPFILES = &H233
Private bUnload As Boolean

Private Sub UserForm_Activate()
    Dim FileDropMessage As MSG
    Dim HDROP As LongPtr
    Dim FileName As String * 256
    Dim ret As Long
    
    'get the listbox handle
    hwnd = FindWindow(vbNullString, Me.Caption)
    hwnd = FindWindowEx(hwnd, 0, vbNullString, vbNullString)
    hwnd = FindWindowEx(hwnd, 0, vbNullString, vbNullString)
    
    'make the listbox accept dropped file
    DragAcceptFiles hwnd, True
    
    bUnload = False
    Do
        'wait for a file to be dropped
        WaitMessage
        Call PeekMessage(FileDropMessage, 0, 0, 0, 0)
        'if file dropped on the listbox then retrieve the name of the dropped file
        If PeekMessage(FileDropMessage, hwnd, WM_DROPFILES, WM_DROPFILES, PM_REMOVE Or PM_NOYIELD) Then
            HDROP = FileDropMessage.wParam
            ret = DragQueryFile(HDROP, 0, FileName, Len(FileName))
            ListBox1.AddItem Left(FileName, ret)
            'Release memory
            DragFinish HDROP
        End If
        DoEvents
    Loop Until bUnload
End Sub

Private Sub UserForm_Terminate()
    'exit msg loop
    bUnload = True
End Sub
Click to expand...


Bonjour Jaafar et merci pour ta réponse.

Je suis aussi allé faire un tour sur ton blog. Tu as de belles photos vintages de Larache. Ca a l'air joli comme endroit.

I also tried the code you sent me and I do not get any errors in the editor now. Thanks.
However, when I try to drag and drop files from explorer to the list box I do not get the path and filename.

My goal is to drag drop files from explorer to get a list of those filename and path in a cell like A1, A2... to the last empty cell of the A column.

This is well above my knowledge and I was wondering if you could help me in that.

Thanks
 
Last edited:
Upvote 0
jbesclapez said:
Bonjour Jaafar et merci pour ta réponse.

Je suis aussi allé faire un tour sur ton blog. Tu as de belles photos vintages de Larache. Ca a l'air joli comme endroit.

I also tried the code you sent me and I do not get any errors in the editor now. Thanks.
However, when I try to drag and drop files from explorer to the list box I do not get the path and filename.

My goal is to drag drop files from explorer to get a list of those filename and path in a cell like A1, A2... to the last empty cell of the A column.

This is well above my knowledge and I was wondering if you could help me in that.

Thanks
Click to expand...

Bonjour Mr jbesclapez et merci d'avoir visité mon petit blog de photos :)

Are you saying that you tried the code on a listbox on a UserForm and that it didn't work ? if so, did you get any errors ?

Later on, I'll take a look at placing the filepaths in the cells as you have requested and see what If I make it work.

Regards.
 
Upvote 0
Jaafar Tribak said:
Bonjour Mr jbesclapez et merci d'avoir visité mon petit blog de photos :)

Are you saying that you tried the code on a listbox on a UserForm and that it didn't work ? if so, did you get any errors ?

Later on, I'll take a look at placing the filepaths in the cells as you have requested and see what If I make it work.

Regards.
Click to expand...

Thanks a LOT !:lol:

I install the code in the code of the userform. In the userform I did put a listbox and then the code inside the object.
Then created a button on my spreadsheet to show the userform. I tested using drag drop but nothing shows in the listbox or in my spreadsheet.
Here is the file I created if you want to have a look at it :
https://www.dropbox.com/s/i6eue7u7ok9xd16/DragDrop get Name.xlsm?dl=0

Thanks for your time Jaafar
 
Upvote 0
jbesclapez said:
Thanks a LOT !:lol:

I install the code in the code of the userform. In the userform I did put a listbox and then the code inside the object.
Then created a button on my spreadsheet to show the userform. I tested using drag drop but nothing shows in the listbox or in my spreadsheet.
Here is the file I created if you want to have a look at it :
https://www.dropbox.com/s/i6eue7u7ok9xd16/DragDrop get Name.xlsm?dl=0

Thanks for your time Jaafar
Click to expand...

Hi jbesclapez ,
The code used in the link you posted is not the code I posted.
 
Upvote 0
Here is the code that should allow you to mouse drag and drop files from explorer onto the cells in Column A of Sheet1 ... Change the destinations worksheet and column in the Module level DROP_SHEET and DROP_COLUMN Constants as required.

Workbook example

Code in a Standard Module :
Code: 
Option Explicit

Private Type POINTAPI
  x As Long
  Y As Long
End Type

Private Type GUID
    lData1 As Long
    iData2 As Integer
    iData3 As Integer
    aBData4(0 To 7) As Byte
End Type


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Type MSG
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    End Type
    
    Private Declare PtrSafe Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As LongPtr, ByVal fAccept As Long)
    Private Declare PtrSafe Sub DragFinish Lib "shell32.dll" (ByVal HDROP As LongPtr)
    Private Declare PtrSafe Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal HDROP As LongPtr, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Sub AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, riid As GUID, ppvObject As Any)
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private hwnd As LongPtr, HDROP As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 

    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
    
    Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)
    Private Declare Sub DragFinish Lib "shell32.dll" (ByVal HDROP As Long)
    Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal HDROP As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Sub AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As Long, ByVal dwId As Long, riid As GUID, ppvObject As Any)
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private hwnd As Long, HDROP As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const OBJID_NATIVEOM = &HFFFFFFF0
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Const PM_NOYIELD = &H2
Private Const PM_REMOVE = &H1
Private Const WM_DROPFILES = &H233

Private bXitLoop As Boolean

Private Const DROP_SHEET As String = "SHEET1" [B][COLOR=#008000]' <== change sheet name as required.[/COLOR][/B]
Private Const DROP_COLUMN As String = "A" [B][COLOR=#008000]' <== change column as required.[/COLOR][/B]


Public Sub StartDropping()
    Dim FileDropMessage As MSG
    Dim FileName As String * 256
    Dim ret As Long
    
    hwnd = GetWorkbookHwnd(ThisWorkbook)
    DoEvents
    DragAcceptFiles hwnd, True
    DoEvents
    bXitLoop = False
    Do
        WaitMessage
        If PeekMessage(FileDropMessage, hwnd, WM_DROPFILES, WM_DROPFILES, PM_REMOVE Or PM_NOYIELD) Then
            HDROP = FileDropMessage.wParam
            ret = DragQueryFile(HDROP, 0, FileName, Len(FileName))
            If ret Then
                Call DropFileName(ThisWorkbook.Worksheets(DROP_SHEET).Columns(DROP_COLUMN), Left(FileName, ret))
            End If
            DragFinish HDROP
        End If
        DoEvents
    Loop Until bXitLoop

End Sub

Public Sub StopDropping()
    bXitLoop = True
End Sub


Private Sub DropFileName(ByVal DropColumn As Range, ByVal FileName As String)
    Dim LastCell As Range
    
    Set LastCell = Worksheets(DROP_SHEET).Cells(Columns(DROP_COLUMN).Rows.Count, 1).End(xlUp)
    If IsEmpty(LastCell) Then LastCell = FileName Else LastCell.Offset(1) = FileName
End Sub

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function GetWorkbookHwnd(ByVal wb As Workbook) As LongPtr
    Dim hChild As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function GetWorkbookHwnd(ByVal wb As Workbook) As Long
    Dim hChild As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim ID_Dispatch As GUID
    Dim oWindow As Window
    
    With ID_Dispatch
        .lData1 = &H20400
        .iData2 = &H0
        .iData3 = &H0
        .aBData4(0) = &HC0
        .aBData4(1) = &H0
        .aBData4(2) = &H0
        .aBData4(3) = &H0
        .aBData4(4) = &H0
        .aBData4(5) = &H0
        .aBData4(6) = &H0
        .aBData4(7) = &H46
    End With
    
    hChild = GetNextWindow(FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString), GW_CHILD)
    Do While hChild
        Call AccessibleObjectFromWindow(hChild, OBJID_NATIVEOM, ID_Dispatch, oWindow)
        If oWindow.Parent Is wb Then GetWorkbookHwnd = hChild: Exit Function
        hChild = GetNextWindow(hChild, GW_HWNDNEXT)
    Loop
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Could not set the RowSource property. Invalid property value. Error 380
2
Replies
16
Views
408
RoryA
RoryA
M
  • Solved
Userform image event handler for date picker?
Replies
4
Views
173
mdeanh5252
M
G
  • Solved
Run-Time Error 381
2
Replies
12
Views
390
Micron
M
S
  • Question Question
PNG
Replies
1
Views
457
Dan_W
D
D
  • Solved
Numeric Value returned when Time format returned to User Form TextBox
Replies
3
Views
221
6StringJazzer
6StringJazzer

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top