'patricktoulon
Sub clearGallery()
Dim shap As Shape
'clear la page
For Each shap In ActiveSheet.Shapes
If shap.Name <> "BoutonGo" Then shap.Delete
Next
Cells.Clear
End Sub
Sub CreatePictureGallery()
Dim p As Range, LargeurCase&, Hauteurcase&, NbCol&, L&, C&, fichiers
'---------------------------------------
clearGallery
'-----------------------------------------
LargeurCase = 2 'largeur de la case en colonnes
Hauteurcase = 7 'hauteur de la case en lignes
NbCol = 4 'nombre de case par ligne
C = 1 'colonne de depart
L = 2 'ligne deparat
'dialog folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "CHOISISSEZ LE DOSSIER D IMAGES"
If .Show <> -1 Then Exit Sub
dossier = .SelectedItems(1) & "\"
End With
'dir fichier
fichiers = Dir(dossier & "\*.*")
If fichiers <> "" Then
Do While fichiers <> ""
Select Case Split(LCase(fichiers), ".")(1)
Case "jpg", "jpeg", "png", "gif", "bmp"
Set p = Cells(L, C).Resize(Hauteurcase, LargeurCase)
p.BorderAround 1, 2, 3 'encadrement en rouge(facultatif)
DoEvents
'insertion de limage
Set img = ActiveSheet.Pictures.Insert(dossier & fichiers)
PlaceTheShapeInCenterRange p, img, 90 '90%
C = C + LargeurCase 'passe a la case suivante
If C = (1 + (LargeurCase * NbCol)) Then C = 1: L = L + Hauteurcase 'on change de ligne au bout de 4 case alignées
End Select
fichiers = Dir
Loop
End If
End Sub
Sub PlaceTheShapeInCenterRange(rng As Range, shap As Variant, Optional marge As Long = 100) 'la marge exprime un pourcentage de 1 à x%
'fonction de placement et centrage d'image dans un range
'auteur:patricktoulon
'Archive 2020;Version :2020
Dim Ratio#, Shapo As Shape
Ratio = Application.Min(((rng.Width) * (marge / 100)) / shap.Width, ((rng.Height) * (marge / 100)) / shap.Height)
Set Shapo = ActiveSheet.Shapes(shap.Name)
With Shapo
.LockAspectRatio = msoTrue
.Width = (.Width * Ratio)
.Top = rng.Top + ((rng.Height - .Height) / 2)
.Left = rng.Left + ((rng.Width - .Width) / 2)
End With
End Sub