XL 2016 Gestion et placement de photos avec le nom

[Webperegrino]

Bonjour Le Forum,

Dans la petite application ci-jointe j’ai réussi à faire parfaitement fonctionner deux macros commandées par les deux boutons « Place à l’unité » et « Efface tout » jouant dans le pavé B2:J26.

Pour la troisième macro, quant à elle liée au bouton central « PLACE TOUT », je ne peux la faire fonctionner convenablement :

• Je dois l’arrêter avec un blocage de fonctionnement en boucle tant que je n’actionne pas "Ctrl + Pause" pour sortir de la macro
• Une seule et première photo se place partout dans ce pavé B2 :J26, au lieu de placer les suivantes, une à une et selon l’ordre positionné dans un dossier voisin « TROMBINOSCOPE » contenant les photos ou images.

Merci d’avance à celui qui pourra corriger cette troisième macro ; j'y suis depuis quatre jours et je bloque désespérément...

Webperegrino

 

[fanch55]

Salut, dans le classeur joint:
Module ThisWorkBook pour renseigner la variable de classeur PhotoDir :

Private Sub Workbook_Open()
    Do While Dir([PhotoDir]) = ""
        Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
        With Fd
            .AllowMultiSelect = False
            .Filters.Clear
            .Title = "Sélection du dossier des Photos"
            .InitialFileName = [PhotoDir]
            If .Show = -1 Then
                Names("PhotoDir").RefersToR1C1 = .SelectedItems(1) & "\"
            Else
                ThisWorkbook.Close False
            End If
        End With
        Set Fd = Nothing
    Loop
End Sub

Modification dans Feuil1 de la sub CommandButton2_Click

Private Sub CommandButton2_Click() 'Tout placer
Dim Row As Integer, Col As Integer
Dim File As Variant, Fso As Object
Application.ScreenUpdating = False
    CommandButton3_Click
    [A3] = 0
    Set Fso = CreateObject("Scripting.FileSystemObject")
        Row = 3
        Col = Columns("B").Column
        For Each File In Fso.GetFolder([PhotoDir]).Files
            If File.Name Like "*.jpg" Then
                [A3] = [A3] + 1
                Cells(Row, Col) = Fso.getBasename(File)
                PlaceThePictureInCenterRange Cells(Row - 1, Col), Shapes.AddPicture(File, False, True, 20, 20, -1, -1), 90
                If Col = Columns("J").Column Then
                    Col = 2: Row = Row + 3
                Else
                    Col = Col + 2
                End If
            End If
        Next
    Set Fso = Nothing ' Libération mémoire
End Sub

End Sub

 

[Webperegrino]

Bonjour Le Forum,
Bonjour Fanch55,
Merci pour votre intervention.
C'est parfaitement ce que je souhaitais.
Je vais me pencher sur vos corrections excellentes.
Merci encore, j'ai vérifié et ça fonctionne très bien.
Cordialement,
Webperegrino