Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi,
As the title suggests, the code allows you to drag thumbnails from explorer onto the activesheet and automatically converts them to excel Shapes.
I've written and tested the code in Excel 2016 x64bit so I would love to know if it works in other versions as well.. If any of you tries the code in other Excel versions (specially excel 2007) please, do let me know if it works ok.
Workbook Example
1- API code in a Standard Module:
2- Code usage example in a Standard Module :
As the title suggests, the code allows you to drag thumbnails from explorer onto the activesheet and automatically converts them to excel Shapes.
I've written and tested the code in Excel 2016 x64bit so I would love to know if it works in other versions as well.. If any of you tries the code in other Excel versions (specially excel 2007) please, do let me know if it works ok.
Workbook Example
1- API code in a Standard Module:
VBA Code:
Option Explicit
Private Enum vtbl_IShellItemImageFactory
QueryInterface_
AddRef_
Release_
GetImage_
End Enum
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type Size
cx As Long
cy As Long
End Type
Public Type tDragDrop
#If Win64 Then
pVtable As LongPtr
Func(6) As LongPtr
hwnd As LongPtr
CallBackAddr As LongPtr
#Else
pVtable As Long
Func(6) As Long
hwnd As Long
CallBackAddr As Long
#End If
FilePath As String
ThumbSize As Size
MsgPumpFlag As Boolean
End Type
Private Type MSG
#If Win64 Then
hwnd As LongPtr
message As Long
wParam As LongPtr
lParam As LongPtr
#Else
hwnd As Long
message As Long
wParam As Long
lParam As Long
#End If
time As Long
pt As POINTAPI
End Type
Private Type uPicDesc
Size As Long
Type As Long
#If VBA7 Then
hPic As LongPtr
hPal As LongPtr
#Else
hPic As Long
hPal As Long
#End If
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
#If Win64 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
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 SHGetIDListFromObject Lib "Shell32" (ByVal pUnk As LongPtr, ByRef ppidl As LongPtr) As Long
Private Declare PtrSafe Function SHGetPathFromIDListW Lib "Shell32" (ByVal pidl As LongPtr, ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As Any) As Long
Private Declare PtrSafe Function SHCreateItemFromParsingName Lib "Shell32" (ByVal pPath As LongPtr, ByVal pBC As Long, riid As Any, ppV As Any) 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 Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop 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 DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Private Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
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 IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private hdc As LongPtr, hInitMemDC As LongPtr, hInitMemBmp As LongPtr
#Else
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 SHGetIDListFromObject Lib "Shell32" (ByVal pUnk As Long, ByRef ppidl As Long) As Long
Private Declare Function SHGetPathFromIDListW Lib "Shell32" (ByVal pidl As Long, ByVal pszPath As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As Any) As Long
Private Declare Function SHCreateItemFromParsingName Lib "Shell32" (ByVal pPath As Long, ByVal pBC As Long, riid As Any, ppV As Any) 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 Function GetSystemMetrics Lib "user32" (ByVal nIndex 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) 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 Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "OleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private hdc As Long, hInitMemDC As Long, hInitMemBmp As Long
#End If
Private tDragDrop As tDragDrop
#If Win64 Then
Public Sub EnableDragAndDrop(ByVal hwnd As LongPtr, ByVal cx As Long, cy As Long, ByVal CallBackAddr As LongPtr)
#Else
Public Sub EnableDragAndDrop(ByVal hwnd As Long, ByVal cx As Long, cy As Long, ByVal CallBackAddr As Long)
#End If
If IsWindow(hwnd) Then
With tDragDrop
.pVtable = VarPtr(.Func(0))
.hwnd = hwnd
.ThumbSize.cx = cx
.ThumbSize.cy = cy
.CallBackAddr = CallBackAddr
#If VBA7 Then
.Func(0) = VBA.CLngPtr(AddressOf QueryInterface)
.Func(1) = VBA.CLngPtr(AddressOf AddRef)
.Func(2) = VBA.CLngPtr(AddressOf Release)
.Func(3) = VBA.CLngPtr(AddressOf DragEnter)
.Func(4) = VBA.CLngPtr(AddressOf DragOver)
.Func(5) = VBA.CLngPtr(AddressOf DragLeave)
.Func(6) = VBA.CLngPtr(AddressOf Drop)
#Else
.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
RegisterDragDrop .hwnd, VarPtr(.pVtable)
End With
If tDragDrop.MsgPumpFlag = False Then
Call DisableDragAndDrop
tDragDrop.MsgPumpFlag = True
Call EnableDragAndDrop(tDragDrop.hwnd, cx, cy, CallBackAddr)
Call MessagePump
End If
End If
End Sub
Public Sub DisableDragAndDrop()
With tDragDrop
If .hwnd Then
.MsgPumpFlag = False
tDragDrop = tDragDrop
RevokeDragDrop .hwnd
End If
End With
End Sub
#If Win64 Then
Public Function GetXL7Hwnd() As LongPtr
Dim hDsk As LongPtr, hXl7 As LongPtr
#Else
Public Function GetXL7Hwnd() As Long
Dim hDsk As Long, hXl7 As Long
#End If
hDsk = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
GetXL7Hwnd = FindWindowEx(hDsk, 0, "EXCEL7", vbNullString)
End Function
Private Sub MessagePump()
Dim tMsg As MSG
Do While GetMessage(tMsg, tDragDrop.hwnd, 0, 0) And tDragDrop.MsgPumpFlag
DoEvents
Call PostMessage(tMsg.hwnd, tMsg.message, tMsg.wParam, tMsg.lParam)
Loop
Debug.Print "Thumbnail DragAndDrop" & vbCr & "Disabled."
End Sub
#If Win64 Then
Private Function QueryInterface(This As tDragDrop, ByVal riid As LongPtr, ByRef pObj As LongPtr) As Long
#Else
Private Function QueryInterface(This As tDragDrop, 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 tDragDrop) As Long
End Function
Private Function Release(This As tDragDrop) As Long
End Function
#If Win64 Then
Private Function DragEnter(This As tDragDrop, ByVal pDataObj As LongPtr, ByVal KeyState As Long, ByVal pt As LongPtr, ByRef pdwEffect As Long) As Long
Dim pidl As LongPtr
#Else
Private Function DragEnter(This As tDragDrop, ByVal pDataObj As Long, ByVal KeyState As Long, ByVal x As Long, g, ByVal y As Long, ByRef pdwEffect As Long) As Long
Dim pidl As Long
#End If
Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1
Const SRCCOPY = &HCC0020
Dim lScrwidth As Long, lScrHeight As Long
Dim sBuff As String
If SHGetIDListFromObject(pDataObj, pidl) = 0 Then
sBuff = String$(256, 0)
If SHGetPathFromIDListW(pidl, StrPtr(sBuff)) Then
This.FilePath = VBA.Left$(sBuff, VBA.InStr(sBuff, vbNullChar))
lScrwidth = GetSystemMetrics(SM_CXSCREEN): lScrHeight = GetSystemMetrics(SM_CYSCREEN)
hdc = GetDC(0)
hInitMemDC = CreateCompatibleDC(hdc)
hInitMemBmp = CreateCompatibleBitmap(hdc, lScrwidth, lScrHeight)
Call SelectObject(hInitMemDC, hInitMemBmp)
Call BitBlt(hInitMemDC, 0, 0, lScrwidth, lScrHeight, hdc, 0, 0, SRCCOPY)
End If
End If
End Function
Private Function DragLeave(This As tDragDrop) As Long
Call CleanUp
End Function
#If Win64 Then
Private Function DragOver(This As tDragDrop, ByVal KeyState As Long, ByVal pt As LongPtr, ByRef pdwEffect As Long) As Long
Dim hCanvasDc As LongPtr, hCanvasBmp As LongPtr, tCur As POINTAPI
Call CopyMemory(tCur, pt, LenB(pt))
#Else
Private Function DragOver(This As tDragDrop, ByVal KeyState As Long, ByVal x As Long, ByVal y As Long, ByRef pdwEffect As Long) As Long
Dim hCanvasDc As Long, hCanvasBmp As Long, tCur As POINTAPI
tCur.x = x: tCur.y = y
#End If
Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1
Const SRCCOPY = &HCC0020
Dim lScrwidth As Long, lScrHeight As Long
On Error GoTo err_Handler
With This
If Len(.FilePath) Then
hCanvasDc = CreateCompatibleDC(hdc)
lScrwidth = GetSystemMetrics(SM_CXSCREEN): lScrHeight = GetSystemMetrics(SM_CYSCREEN)
Call BitBlt(hCanvasDc, 0, 0, lScrwidth, lScrHeight, hInitMemDC, 0, 0, SRCCOPY)
hCanvasBmp = GetBmpFromFileThumbnail(This)
Call SelectObject(hCanvasDc, hCanvasBmp)
Call BitBlt(hdc, 0, 0, lScrwidth, lScrHeight, hInitMemDC, 0, 0, SRCCOPY)
Call BitBlt(hdc, tCur.x - .ThumbSize.cx / 2, tCur.y - .ThumbSize.cy / 2, lScrwidth, lScrHeight, hCanvasDc, 0, 0, SRCCOPY)
Call DeleteDC(hCanvasDc)
Call DeleteObject(hCanvasBmp)
End If
End With
Exit Function
err_Handler:
Call DisableDragAndDrop
End Function
#If Win64 Then
Private Function Drop(This As tDragDrop, ByVal pDataObj As Long, ByVal KeyState As Long, ByVal pt As LongPtr, ByRef pdwEffect As Long) As Long
Dim tCur As POINTAPI, hBmp As LongPtr
Call CopyMemory(tCur, pt, LenB(pt))
#Else
Private Function Drop(This As tDragDrop, ByVal pDataObj As Long, ByVal KeyState As Long, ByVal x As Long, ByVal y As Long, ByRef pdwEffect As Long) As Long
Dim tCur As POINTAPI, hBmp As Long
tCur.x = x: tCur.y = y
#End If
Const CC_STDCALL = 4
Dim oRng As Object, oPic As IPicture
Dim sPath As String, sExt As String
On Error GoTo err_Handler
If Len(This.FilePath) Then
sPath = This.FilePath
sExt = Right(Replace(sPath, " ", ""), 4)
sExt = WorksheetFunction.Clean(Right(Replace(sExt, " ", ""), 4))
If InStr(1, ".bmp.jpgjpeg.png.gif.tiff.psd.raw", sExt, vbTextCompare) = 0 Then
hBmp = GetBmpFromFileThumbnail(This)
Set oPic = CreateStdPicture(hBmp)
Call DeleteObject(hBmp)
If Not oPic Is Nothing Then
sPath = Environ("temp") & Application.PathSeparator & "temp.bmp"
stdole.SavePicture oPic, sPath
End If
End If
Call DispCall(0, 0, This.CallBackAddr, vbEmpty, CC_STDCALL, sPath, tCur.x, tCur.y, KeyState)
End If
Debug.Print KeyState
Call CleanUp
Exit Function
err_Handler:
Call DisableDragAndDrop
End Function
Private Sub CleanUp()
Dim sPath As String
Call InvalidateRect(0, 0, 0)
Call DeleteObject(hInitMemBmp)
Call DeleteDC(hInitMemDC)
Call ReleaseDC(0, hdc)
sPath = Environ("temp") & Application.PathSeparator & "temp.bmp"
If Len(Dir(sPath)) Then
Kill sPath
End If
End Sub
#If Win64 Then
Private Function CreateStdPicture(ByVal BMP As LongPtr) As IPicture
Dim hCopy As LongPtr
#Else
Private Function CreateStdPicture(ByVal BMP As Long) As IPicture
Dim hCopy As Long
#End If
Const IMAGE_BITMAP = 0
Const PICTYPE_BITMAP = 1
Const LR_COPYRETURNORG = &H4
Const S_OK = &H0
Dim IID_IDispatch As GUID, uPicinfo As uPicDesc, iPic As IPicture
hCopy = CopyImage(BMP, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With uPicinfo
.Size = Len(uPicinfo)
.Type = PICTYPE_BITMAP
.hPic = hCopy
.hPal = 0
End With
If OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, iPic) = S_OK Then
Set CreateStdPicture = iPic
End If
End Function
#If Win64 Then
Private Function GetBmpFromFileThumbnail(This As tDragDrop) As LongPtr
Const VTBL_OFFSET = vtbl_IShellItemImageFactory.GetImage_ * 8
Dim hBmp As LongPtr, pUnk As LongPtr, lPt As LongPtr
#Else
Private Function GetBmpFromFileThumbnail(This As tDragDrop)
Const VTBL_OFFSET = vtbl_IShellItemImageFactory.GetImage_ * 4
Dim hBmp As Long, pUnk As Long
#End If
Const CC_STDCALL = 4
Const S_OK = 0
Const IID_IShellItemImageFactory = "{BCC18B79-BA16-442F-80C4-8A59C30C463B}"
Dim lRet As Long, bIID(0 To 15) As Byte, Unk As IUnknown
Dim tSize As Size, sFilePath As String
With This
If .ThumbSize.cx < 16 Then .ThumbSize.cx = 16: If .ThumbSize.cy < 16 Then .ThumbSize.cy = 16
If Len(Dir(.FilePath, vbDirectory)) Then
If CLSIDFromString(StrPtr(IID_IShellItemImageFactory), bIID(0)) = S_OK Then
If SHCreateItemFromParsingName(StrPtr(.FilePath), 0, bIID(0), Unk) = S_OK Then
pUnk = ObjPtr(Unk)
If pUnk Then
tSize.cx = .ThumbSize.cx: tSize.cy = .ThumbSize.cy
#If Win64 Then
CopyMemory lPt, tSize, LenB(tSize)
If DispCall(True, pUnk, VTBL_OFFSET, vbLong, CC_STDCALL, lPt, 0, VarPtr(hBmp)) = S_OK Then
#Else
If DispCall(True, pUnk, VTBL_OFFSET, vbLong, CC_STDCALL, tSize.cx, tSize.cy, 0, VarPtr(hBmp)) = S_OK Then
#End If
If hBmp Then
GetBmpFromFileThumbnail = hBmp
End If
End If
End If
End If
End If
End If
End With
End Function
#If Win64 Then
Private Function DispCall(ByVal Interface As Boolean, ByVal InterfacePointer As LongPtr, ByVal Addr As LongPtr, _
ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
Dim vParamPtr() As LongPtr
#Else
Private Function DispCall(ByVal Interface As Boolean, ByVal InterfacePointer As Long, ByVal Addr As Long, _
ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
Dim vParamPtr() As Long
#End If
Dim vParamType() As Integer
Dim pIndex As Long, pCount As Long
Dim vRtn As Variant, vParams() As Variant
If Interface Then
If InterfacePointer = 0& Or Addr < 0& Then Exit Function
End If
If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function
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, Addr, CallConvention, FunctionReturnType, pCount, vParamType(0), vParamPtr(0), vRtn)
If pIndex = 0& Then
DispCall = vRtn
Else
SetLastError pIndex
End If
End Function
Private Sub Auto_Close()
Call DisableDragAndDrop
End Sub
2- Code usage example in a Standard Module :
VBA Code:
Option Explicit
Dim bDragDropEnabled As Boolean
Sub Start()
If bDragDropEnabled = False Then
bDragDropEnabled = True
Call EnableDragAndDrop(hwnd:=GetXL7Hwnd, cx:=48, cy:=48, CallBackAddr:=AddressOf OnDrop)
End If
End Sub
Sub Finish()
Call DisableDragAndDrop
bDragDropEnabled = False
End Sub
'Pseudo-Event.
Private Sub OnDrop(ByVal FileName As String, ByVal x As Long, ByVal y As Long, ByVal KeyState As Integer)
Dim oRng As Object
Set oRng = Application.ActiveWindow.RangeFromPoint(x, y)
If Not oRng Is Nothing Then
With oRng
Call ActiveSheet.Shapes.AddPicture(FileName:=FileName, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=IIf(TypeName(oRng) = "Range", .Left, .Left + 10), _
Top:=IIf(TypeName(oRng) = "Range", .Top, .Top + 10), _
Width:=.Width, _
Height:=.Height)
End With
End If
End Sub