XL 2010 Afficher une image en passant sur une cellule

Sub CréerCommentaires()
Dim dossier$, fichier$, n&
dossier = ThisWorkbook.Path & "\Images\"
fichier = Dir(dossier & "*.jpg") '1er fichier du dossier
Range("A2:A" & Rows.Count).Delete xlUp 'RAZ
n = 1
While fichier <> ""
    n = n + 1
    Cells(n, 1) = Left(fichier, Len(fichier) - 4) 'nom du fichier sans l'extension
    With Cells(n, 1).AddComment("").Shape
        .Width = 150 'dimension à adapter
        .Height = 150 'dimension à adapter
        .Fill.UserPicture dossier & fichier
    End With
    fichier = Dir 'fichier suivant
Wend
End Sub

Sub CréerFichiersGIF()
Dim dossier$, fichier$
dossier = ThisWorkbook.Path & "\Images\"
fichier = Dir(dossier & "*.jpg") '1er fichier JPEG du dossier
Application.ScreenUpdating = False
While fichier <> ""
    With Me.Pictures.Insert(dossier & fichier) 'crée la Shape
        .CopyPicture
        With Me.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .Paste
            .Export dossier & "\" & Left(fichier, Len(fichier) - 4) & ".gif", "GIF"
            .Parent.Delete 'supprime le graphique temporaire
        End With
        .Delete 'supprime la Shape
    End With
    fichier = Dir
Wend
End Sub

Private Declare Function GetTempFileNameA Lib "Kernel32" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function CloseClipboard Lib "user32" () As Long

Private Declare Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long

Private Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hDC As Long) As Long

Private Sub CommandButton1_Click()
CopiePhoto Range("A1:f30")
    'CopiePhoto ActiveSheet.Shapes(1), 0, 0
End Sub
Sub CopiePhoto(Source As Variant, Optional transparency As Long = 1, Optional borders As Long = 0)
    Dim FichTemp As String
    FichTemp = Space(160)
    GetTempFileNameA Environ("TMP"), "IMG", 0, FichTemp
    FichTemp = Left$(FichTemp, InStr(FichTemp, vbNullChar) - 1)
    'Debug.Print FichTemp
    Source.Copy 'Picture
    OpenClipboard 0
    DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), FichTemp)
    CloseClipboard
    On Error Resume Next
    With Me.Image1
        .Picture = LoadPicture(FichTemp)
        .BackStyle = transparency
        .BorderStyle = 0
        .Move .Left, .Top, Source.Width, Source.Height
    End With
    Kill FichTemp
End Sub