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
