Drag and Drop Shell Thumbnails onto the Worksheet as Shapes

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,779
Office Version
  1. 2016
Platform
  1. 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



ShellDragAndDrop.gif





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
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
Sort by date Sort by votes
Thank you @DanteAmor for letting me know.

So, It works in excel 2007 and in excel 2016 x64. - That's great to know !

Now, It only remains to be confirmed if the code also works in 32bit vba7 editions ( ie: excel 2010 through ==>2019 x32bit)

Because of the health lockdown, I don't have access to other computers for testing so thanks anyone for helping.

Regards.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
0
Views
165
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
747
Jaafar Tribak
Jaafar Tribak
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
309
Minh Tuan VN
M
D
  • Solved
Long vs Longptr
Replies
7
Views
317
Micron
M
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
745
huiettcm
H

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

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