1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
| Option Explicit
Sub incorporer_photos()
Dim feuille As Worksheet
Dim image As Picture
Dim cellule As Range
Dim dossier$, nom$, photo$
Dim dernièreLigne&, ligne&, marge%
Dim orientation#
Call enlever_photos
Set feuille = Worksheets("Feuil1")
With feuille
dossier = ThisWorkbook.Path & "\Photos\Membres\"
dernièreLigne = .Columns("A").Find("*", , , , , xlPrevious).Row
' Dimensionner les cellules de destination
.Columns("C").ColumnWidth = 22.14
.Rows("2:" & dernièreLigne).RowHeight = 120
marge = 5
' Placer les photos
For ligne = 2 To dernièreLigne
nom = .Cells(ligne, "B") & "_" & .Cells(ligne, "A") 'Prénom_Nom
photo = dossier & nom & ".jpg" '...\Prénom_Nom.jpg
If Dir(photo) <> "" Then
Set cellule = .Cells(ligne, "C") 'Destination
Set image = ActiveSheet.Pictures.Insert(photo)
With image.ShapeRange
' Position
.Top = cellule.Top + marge
.Left = cellule.Left + marge
' Adapter la taille selon l'orientation
orientation = image.Width / image.Height
If orientation < 1 Then
' Portrait
.LockAspectRatio = msoTrue
.Height = cellule.Height - 2 * marge
If .Width > cellule.Width - 2 * marge Then .Width = cellule.Width - 2 * marge
.Top = cellule.Top + (cellule.Height - .Height) / 2
.Left = cellule.Left + (cellule.Width - .Width) / 2
Else
' Paysage
.LockAspectRatio = msoTrue
.Width = cellule.Width - 2 * marge
If .Height > cellule.Height - 2 * marge Then .Height = cellule.Height - 2 * marge
.Top = cellule.Top + (cellule.Height - .Height) / 2
.Left = cellule.Left + (cellule.Width - .Width) / 2
End If
.Name = nom
End With
End If
Next
End With
End Sub
Sub enlever_photos()
Dim forme As Shape
For Each forme In Worksheets("Feuil1").Shapes
If forme.Type = msoPicture Then
forme.Delete
End If
Next forme
Worksheets("Feuil1").UsedRange.Offset(1).Rows.AutoFit
End Sub |
Partager