Option Compare Text 'Pour ignorer les Minuscules et Majuscules (Ex: "jpg" et "JPG")
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
'=============================== ON VA CHOISIR UN DOSSIER:
Set RECHERCHE = Application.FileDialog(msoFileDialogFolderPicker)
With RECHERCHE 'ATTENTION! Je n'ai pas géré ici la fermeture intempestive de la boite de dialogue!
.Title = " CHOISIR UN DOSSIER"
.AllowMultiSelect = False
If .Show = -1 Then
For Each CHOIXDOSSIER In .SelectedItems
DOSSIER_PHOTOS = CHOIXDOSSIER
Next CHOIXDOSSIER
End If
End With
Set RECHERCHE = Nothing
Dim ACTION As Object, DOSSIER_CHOISI As Object, PHOTOS_PRESENTES As Object, i As Byte
Set ACTION = CreateObject("Shell.Application")
Set DOSSIER_CHOISI = ACTION.Namespace(DOSSIER_PHOTOS & "\")
N = 2 'Puisque l'on va écrire à partir de la ligne 2 (Voir ci-dessous)
For Each PHOTOS_PRESENTES In DOSSIER_CHOISI.Items
On Error Resume Next 'Car il y peut y avoir des Fichiers sans extension déclarée.
Dim EXTENSION As String
EXTENSION = Mid(PHOTOS_PRESENTES.Path, InStrRev(PHOTOS_PRESENTES.Path, "."), 4) ' Les quatre derniers caractères après le dernier Point du Chemin
If EXTENSION = ".jpg" Or EXTENSION = ".gif" Or EXTENSION = ".bmp" Or EXTENSION = ".jpeg" Then 'Inspiré de l'aide que j'ai reçu
'================================= ON REDIGE LA LISTE:
Worksheets("LISTE").Activate
With ActiveSheet
.Rows(N).RowHeight = 58
NOM = DOSSIER_CHOISI.GetDetailsOf(PHOTOS_PRESENTES, 0)
.Pictures.Insert(PHOTOS_PRESENTES.Path).Name = NOM
.Shapes(NOM).Left = .Cells(1, 2).Left
.Shapes(NOM).Height = 50
.Shapes(NOM).Top = .Cells(N, 1).Top + 2
.Cells(N, 3).Value = DOSSIER_CHOISI.GetDetailsOf(PHOTOS_PRESENTES, 0) 'Nom du Fichier
.Cells(N, 4).Value = PHOTOS_PRESENTES.Path 'Le Chemin Complet
N = N + 1 ' On passe à la ligne suivante.
End With
End If
Next PHOTOS_PRESENTES
ActiveSheet.Columns("A:E").Columns.AutoFit
Application.ScreenUpdating = True
End Sub