Macro excel pour inserer une image!

J'ai eu pour ma fille à réaliser un travail similaire
Elle disposait d'une collection de photos dont le nom commençait toujours par une clef (radical) calculé par rapport à des informations présente sur la ligne sélectionnée

Cette collection de photo était présente dans un dossier nommé photos inclus dans le dossier contenant le fichier excel
1er à l'ouverture de la feuille excel, on récupére le dossier du fichier excel pour pouvoir localiser les photos en remplissant une cellule d'un onglet caché baptisé Fichier
Private Sub Workbook_Open()
Sheets("Fichier").Cells(1, 2).Value = Application.ActiveWorkbook.Path + "\photos"
End Sub

Dans la macro principale je dresse la liste des images à afficher dans un tableau Fichier$
Call fabdirectory(radical$)
ReDim Fichier$(20)
J = 1
r$ = Sheets("Fichier").Cells(1, 2).Value
While Sheets("Fichier").Cells(J, 1).Value <> ""
fmax = fmax + 1
Fichier$(fmax) = r$ + "\" + Sheets("Fichier").Cells(J, 1).Value
J = J + 1
Wend
Ensuite je lance l'affichage des images dans un autre onglet Baptisé Fiche et contenant aussi des informations textuelle
Call ChangeImage(Fichier$(), fmax)

Voici le code de la macro fabdirectory

Sub fabdirectory(radical$)
' Renvoie le nom des fichiers image du dossier photos correspondant au radical
repertoire$ = Sheets("Fichier").Cells(1, 2).Value + "\" + radical$ + "*.*"
Sheets("Fichier").Columns("A:A").ClearContents
Myfile = Dir(repertoire$)
While Myfile <> ""
Term$ = Right$(LCase$(Myfile), 4)
If (Term$ = ".jpg") Or (Term$ = ".gif") Or (Term$ = "jpeg") Or (Term$ = ".bmp") Then
k = k + 1
Sheets("Fichier").Cells(k, 1).Value = Myfile
End If
Myfile = Dir
Wend
End Sub

Voici la macro Afficheimage dans l'onglet fiche. A noter que je commence par retirer toutes les images présentes dans cet onglet puis je réinsére toutes les images trouvées dans la recherche précédente les unes en dessous des autres et je les redimensionne une à une pour qu'elles aient toutes une taille homogéne

Sub ChangeImage(Fichier$(), fmax)
Dim objFeuille As Worksheet, objPict(20) As Picture
Sheets("Fiche").Select
' Effacement eventuel des images de l'affichage précédent
On Error Resume Next
For i = 1 To 20
nom$ = "Image" + Trim$(Str$(i))
ActiveSheet.Shapes(nom$).Delete
Next i
On Error GoTo 0
Set objFeuille = Sheets("Fiche")
For i = 1 To fmax
F$ = Fichier$(i)
'Ajout de l'image
Set objPict(i) = objFeuille.Pictures.Insert(F$)
'Determination d'un coeficient de réduction d'image
Largeur = objPict(i).Width
Hauteur = objPict(i).Height
Kh = 300 / Hauteur
Kl = 300 / Largeur
If Kl > Kh Then
k = Kh
Else
k = Kl
End If
' Positionnement et redimentionnement
With objPict(i)
.Name = "Image" + Trim$(Str$(i))
.Left = Range("D4").Left
.Top = Range("D4").Top + Decallage
.ShapeRange.ScaleWidth k, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleHeight k, msoFalse, msoScaleFromTopLeft
End With
' Determination de la position suivante
Decallage = objPict(i).Top + objPict(i).Height + 2
Next i
End Sub