XL 2016 Positionner une image au centre d'une cellule

[Laosurlamontagne]

Bonjour à tous,

J'ai une macro événementiel qui me permet d'ajouter un fichier sur une cellule en cliquant 2 fois dessus. Elle fonctionne très bien, cependant, je n'arrive pas à centrer le fichier sur la cellule. Il se positionne par défaut en haut à gauche et c'est pas très jolie...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Application.Intersect(Target, Range("Table")) Is Nothing Then

Dim Reponse As Variant
Dim FileName$
Dim SH As Shape
'--- Choix d'un fichier ---
Reponse = Application.GetOpenFilename( _
    FileFilter:="Tout fichier (*.*), *.*", _
    Title:="Insérer un fichier sous forme d'icône dans la cellule active")
If Reponse = False Then Exit Sub
FileName$ = Mid(Reponse, InStrRev(Reponse, "\") + 1)
'--- Le fichier est-il déjà présent ? ---
On Error Resume Next
For Each SH In ActiveSheet.Shapes
  If SH.AlternativeText = Reponse Then
    Range(SH.TopLeftCell.Address).Select
    MsgBox prompt:="Le fichier ''" & Reponse & "'' existe déjà" & vbLf & _
          " en cellule " & SH.TopLeftCell.Address(False, False), _
          Title:="Le fichier sous forme d'icône existe déjà"
    Exit Sub
  End If
Next SH
On Error GoTo 0

Application.ScreenUpdating = False
'--- Crée la Shape ---
Set SH = ActiveSheet.Shapes.AddOLEObject( _
    FileName:=Reponse, DisplayAsIcon:=False, _
    IconFileName:=Application.Path & "\" & "Excel.exe", _
    IconIndex:=0, IconLabel:=FileName$)
'--- Propriétés de la Shape ---
SH.AlternativeText = Reponse  'Identificateur unique

SH.TopLeftCell = ActiveCell   'Localisation sur cellule

    '°°° Taille °°°
SH.Width = 40
SH.Height = 40

Application.ScreenUpdating = True

  Cancel = True
End If
End Sub

Quelqu'un aurait-il une solution?

Merci par avance.

 

[Lone-wolf]

Bonjour laosurlamontagne
ça fait longtemps?! Le chalet y est toujours???

Uun exemple à adapter selon la grandeur des cellules.

For Each sh In ActiveSheet.Shapes
sh.Top = ActiveCell.Top + 5
sh.Left = ActiveCell.Left + 5
Next sh

 

[Laosurlamontagne]

Il est encore sous la neige...

Ca ne centre pas le fichier sur la cellule mais les lignes de code me permettent de le positionner comme je le souhaite.

Merci pour ton aide!