Attribute VB_Name = "APIDragDropPaths"
Option Explicit

Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hWnd As Long, ByVal fAccept 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

Private Const WM_DROPFILES = &H233
Private Const GWL_WNDPROC = -4

Private ControlesColeccion As New Collection
Public DragDropRutas() As String
Public nDragDropRutas As Long
Private DragDropTimerID As Long

Public Function RegistrarControl(CtrlHwnd As Long, SubAddress As Long, Optional AgregarMultiple As Byte = 0) As Boolean
'Registra un control para que acepte archivos y carpetas arrastradas desde el
'explorador de windows
'CtrlHwnd: el Window Handle del control
'SubAddress: la dirección del procedimiento que se dispará cuando el evento suceda
'           (obtenida con AddressOf)
'AgregarMultiple: 1 para habilitar el múltiple agregado de rutas
'Devuelve: True si el control fue registrado con éxito
'
'Las rutas de los archivos y carpetas arrastrados se guardan en DragDropRutas()
'El número de rutas arrastradas se guarda en nDragDropRutas
'El procedimiento al que apunta SubAddress deberá contener el código para
'procesar dicha lista de rutas y deberá iniciar con una llamada a la función
'DragDropMatarTimer() para detener su ejecución repetida puesto que dicho procedimiento
'se ejecuta mediante un Timer creado con la API SetTimer

'Ejemplo de Procedimiento para procesar Paths
'   Public Sub ProcesarPaths()
'       Call APIDragDropPaths.DragDropMatarTimer '<-esta instrucción siempre debe ir
'
'       Dim i As Integer
'
'       For i = 1 To APIDragDropPaths.nDragDropRutas
'           Form1.List1.AddItem APIDragDropPaths.DragDropRutas(i)
'       Next
'
'       Erase APIDragDropPaths.DragDropRutas '<-resetear la lista de paths es opcional pero siempre debería hacerse
'       APIDragDropPaths.nDragDropRutas = 0
'   End Sub

On Error GoTo ErrH
Dim PrevLong As Long
Call DragAcceptFiles(CtrlHwnd, True)
PrevLong = SetWindowLong(CtrlHwnd, GWL_WNDPROC, AddressOf Drag_Drop_Sub)
If PrevLong = 0 Then
    Call DragAcceptFiles(CtrlHwnd, False)
    Exit Function
End If
ControlesColeccion.Add CtrlHwnd
ControlesColeccion.Add SubAddress
ControlesColeccion.Add PrevLong
ControlesColeccion.Add AgregarMultiple
RegistrarControl = True
ErrH:
End Function

Public Sub DeshabilitarDragDrop(CtrlHwnd As Long)
'Deshabilita el evento Drag And Drop en el control
'CtrHwnd: el Window Handle del control
Dim i As Long, PrevLong As Long
For i = 1 To ControlesColeccion.Count Step 4
    If ControlesColeccion(i) = CtrlHwnd Then
        Call DragAcceptFiles(CtrlHwnd, False)
        PrevLong = ControlesColeccion(i + 2)
        Call SetWindowLong(CtrlHwnd, GWL_WNDPROC, PrevLong)
        ControlesColeccion.Remove i + 3
        ControlesColeccion.Remove i + 2
        ControlesColeccion.Remove i + 1
        ControlesColeccion.Remove i
        Exit For
    End If
Next
End Sub

Private Function Drag_Drop_Sub(ByVal hWnd As Long, ByVal WMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim PrevLong As Long, i As Long
Dim Ruta As String * 512, RutaStr As String
Dim SubAddress As Long, AgregarMultiple As Byte
For i = 1 To ControlesColeccion.Count Step 4
    If ControlesColeccion(i) = hWnd Then
        AgregarMultiple = ControlesColeccion(i + 3)
        PrevLong = ControlesColeccion(i + 2)
        SubAddress = ControlesColeccion(i + 1)
        Exit For
    End If
Next
If WMsg = WM_DROPFILES Then
    nDragDropRutas = DragQueryFile(wParam, -1, Ruta, 512)
    If nDragDropRutas > 0 And (AgregarMultiple = 1 Or (AgregarMultiple = 0 And nDragDropRutas = 1)) Then
        ReDim DragDropRutas(1 To nDragDropRutas)
        For i = 0 To nDragDropRutas - 1
            Call DragQueryFile(wParam, i, Ruta, 512)
            RutaStr = CortarRuta(Ruta)
            DragDropRutas(i + 1) = RutaStr
        Next
        DragDropTimerID = SetTimer(ByVal 0&, ByVal 1&, ByVal 1&, ByVal SubAddress)
    End If
End If
Drag_Drop_Sub = CallWindowProc(PrevLong, hWnd, WMsg, wParam, lParam)
End Function

Public Sub DragDropMatarTimer()
Call KillTimer(ByVal 0&, ByVal DragDropTimerID)
DragDropTimerID = 0
End Sub

Private Function CortarRuta(Ruta As String) As String
'Quita los caracteres nulos Chr(0) al final de la ruta
Dim i As Integer, Ret As String
For i = 512 To 1 Step -1
    If Mid(Ruta, i, 1) <> Chr(0) Then
        CortarRuta = Left(Ruta, i)
        Exit Function
    End If
Next
End Function
