'--------------------------------------------------------------------
'Website: https://tuhocvba.net/threads/dragdrop-tren-office-64bit.700/#post-3958
'Tham khao: http://www.excel.studio-kazu.jp/kw/20181211140007.html
'
'Admin tuhocvba & Euler website tuhocvba.net da kiem tra va test thu OK
'====================================================================
Public Type TDragDrop
pfn As LongPtr
fn(6) As LongPtr
rt(3) As Long
hClient As LongPtr
ctl As IControl
End Type
Private Const E_NOTIMPL = &H80004001
Private Const E_NOINTERFACE = &H80004002
Private Const GA_ROOT = 2&
Private Const GW_CHILD = 5&
#If Win64 Then
Private Const PTR_GAP = 8&
Private Declare PtrSafe Function PtInRect& Lib "User32" _
(ByVal lprc As LongPtr, _
ByVal pt As LongPtr)
#Else
Private Const PTR_GAP = 4&
Private Declare PtrSafe Function PtInRect& Lib "User32" _
(ByVal lprc As LongPtr, _
ByVal ptX As Long, ByVal ptY As Long)
#End If
Private Declare PtrSafe Sub MoveMemory Lib "Kernel32" Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
Optional ByVal Length As Long = PTR_GAP)
Private Declare PtrSafe Function RegisterDragDrop& Lib "Ole32" _
(ByVal Hwnd As LongPtr, _
ByVal pDropTarget As LongPtr)
Private Declare PtrSafe Function RevokeDragDrop& Lib "Ole32" _
(ByVal Hwnd As LongPtr)
Private Declare PtrSafe Function SHGetIDListFromObject& Lib "Shell32" _
(ByVal pUnk As LongPtr, _
ByRef ppidl As LongPtr)
Private Declare PtrSafe Function SHGetPathFromIDListW& Lib "Shell32" _
(ByVal pidl As LongPtr, _
ByVal pszPath As LongPtr)
Private Declare PtrSafe Function IUnknown_GetWindow& Lib "Shlwapi" Alias "#172" _
(ByVal pUnk As LongPtr, _
ByRef phwnd As LongPtr)
Private Declare PtrSafe Function GetAncestor Lib "User32" _
(ByVal Hwnd As LongPtr, _
ByVal gaFlags As Long) As LongPtr
Private Declare PtrSafe Function GetWindow Lib "User32" _
(ByVal Hwnd As LongPtr, _
ByVal uCmd As Long) As LongPtr
Public Sub InitDragDrop(This As TDragDrop, ByVal ctl As IControl)
Dim buf As Object
With This
'Tu tao IDropTarget Interface
.pfn = VarPtr(.fn(0))
MoveMemory .fn(0), AddressOf QI
MoveMemory .fn(1), AddressOf AR
.fn(2) = .fn(1)
MoveMemory .fn(3), AddressOf DragEnter
MoveMemory .fn(4), AddressOf DragOver
MoveMemory .fn(5), AddressOf DragLeave
MoveMemory .fn(6), AddressOf Drop
Set .ctl = ctl: Set buf = ctl
Do
IUnknown_GetWindow ObjPtr(buf), .hClient
If .hClient Then Exit Do
Set buf = buf.Parent
Loop
If GetAncestor(.hClient, GA_ROOT) = .hClient Then
.hClient = GetWindow(.hClient, GW_CHILD)
End If
RegisterDragDrop .hClient, VarPtr(.pfn)
End With
End Sub
Public Sub TerminateDragDrop(This As TDragDrop)
With This
If .hClient = 0 Then Exit Sub
RevokeDragDrop .hClient
End With
End Sub
Private Function QI&(ByVal pThis As LongPtr, _
ByVal riid As LongPtr, _
ByRef pObj As LongPtr)
'Msg nay khong duoc goi
QI = E_NOINTERFACE
End Function
Private Function AR&(ByVal pThis As LongPtr)
'Trong truong hop can thiet phai goi
End Function
#If Win64 Then
Private Function DragEnter&(This As TDragDrop, _
ByVal pDataObj As LongPtr, _
ByVal grfKeyState As Long, _
ByVal pt As LongPtr, _
ByRef pdwEffect As Long)
#Else
Private Function DragEnter&(This As TDragDrop, _
ByVal pDataObj As LongPtr, _
ByVal dummy As Variant)
#End If
Dim acc As IAccessible
With This
Set acc = .ctl
acc.accLocation .rt(0), .rt(1), .rt(2), .rt(3)
.rt(2) = .rt(2) + .rt(0)
.rt(3) = .rt(3) + .rt(1)
End With
End Function
#If Win64 Then
Private Function DragOver&(This As TDragDrop, _
ByVal grfKeyState As Long, _
ByVal pt As LongPtr, _
ByRef pdwEffect As Long)
If PtInRect(VarPtr(This.rt(0)), pt) = 0 Then
DragOver = E_NOTIMPL
End If
End Function
#Else
Private Function DragOver&(This As TDragDrop, _
ByVal grfKeyState As Long, _
ByVal ptX As Long, _
ByVal ptY As Long, _
ByRef pdwEffect As Long)
If PtInRect(VarPtr(This.rt(0)), ptX, ptY) = 0 Then
DragOver = E_NOTIMPL
End If
End Function
#End If
Private Function DragLeave&(ByVal pThis As LongPtr)
DragLeave = E_NOTIMPL
End Function
#If Win64 Then
Private Function Drop&(This As TDragDrop, _
ByVal pDataObj As LongPtr, _
ByVal grfKeyState As Long, _
ByVal pt As LongPtr, _
ByRef pdwEffect As Long)
#Else
Private Function Drop&(This As TDragDrop, _
ByVal pDataObj As LongPtr, _
ByVal grfKeyState As Long, _
ByVal ptX As Long, _
ByVal ptY As Long, _
ByRef pdwEffect As Long)
#End If
Dim pidl As LongPtr, buf$, hr&
hr = SHGetIDListFromObject(pDataObj, pidl)
If hr < 0 Then
buf = "$(error)"
Else
buf = String$(256, 0)
If SHGetPathFromIDListW(pidl, StrPtr(buf)) Then
buf = VBA.Left$(buf, VBA.InStr(buf, vbNullChar))
Else
buf = vbNullString
End If
End If
This.ctl.Text = buf
End Function
