Insertion images multiples avec nom fichier

Bonjour à toutes et à tous,

Malgré de nombreuses heures de recherches, tant sur des forums en français qu'en anglais, je ne suis parvenu à trouver qu'une partie de ce que je recherche. Je me tourne donc vers vous en espérant que vous pourrez m'aider

Mon problème est simple : ayant souvent de nombreuses photos à incorporer à mes documents, je cherche une macro qui peut me permettre de :

• Sélectionner un fichier dans lequel sont stockées mes photos
• Sélectionner une ou plusieurs de ces photos
• Insérer chaque photo sélectionnée dans une cellule séparée
• Dans une cellule (adjacente), indiquer le nom de la photo
• Définir la zone d'impression en fonction du nombre de photos insérées

Comme vous l'avez peut-être déjà compris via mes smileys, il n'y a qu'une étape qui me pose problème. Mais c'est presque la plus importante, et celle qui bloque complètement un export final correct et rapide du fichier.

J'en profite pour insister sur un point : je ne souhaite PAS insérer mes photos selon un nom qui serait tapé préalablement dans le fichier Excel. Je dois absolument les sélectionner dans le dossier, le nom doit donc s'écrire APRES selon la sélection.

Voici le code que j'utilise actuellement, qui m'oblige donc à entrer les numéros de photos manuellement à côté de chacune d'elles :

Sub InsertPictures()

Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next

'Redimensionner lignes
Application.ScreenUpdating = False

Range("A16").Select

For i = 16 To 1000 Step 3   'XXXXX
Rows(i).RowHeight = 185
Next i

Range("A17").Select

For i = 17 To 999 Step 3    'XXXXX
Rows(i).RowHeight = 15
Rows(i + 1).RowHeight = 15
Next i

Range("A16").Select

Application.ScreenUpdating = True 'Avant la fin, en cas de fermeture de la fenêtre de choix des photos

PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)

        xRowIndex = xRowIndex + 3   'Saute 1 ligne sur 3
    Next
End If

derlignec = Range("C65536").End(xlUp).Row + 1

Range("A1:C" & derlignec).Select

Sheets("Dossier photos").PageSetup.PrintArea = "A1:C" & derlignec

Range("A15").Select

End Sub

D'avance merci

Bonsoir,

un essai non testé, suite à une idée... :

Sub InsertPictures()

Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next

'Redimensionner lignes
Application.ScreenUpdating = False

Range("A16").Select

For i = 16 To 1000 Step 3   'XXXXX
Rows(i).RowHeight = 185
Next i

Range("A17").Select

For i = 17 To 999 Step 3    'XXXXX
Rows(i).RowHeight = 15
Rows(i + 1).RowHeight = 15
Next i

Range("A16").Select

Application.ScreenUpdating = True 'Avant la fin, en cas de fermeture de la fenêtre de choix des photos

PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        Cells(xRowIndex, xColIndex +1 ) = PicList(lLoop).Name
        xRowIndex = xRowIndex + 3   'Saute 1 ligne sur 3
    Next
End If

derlignec = Range("C65536").End(xlUp).Row + 1

Range("A1:C" & derlignec).Select

Sheets("Dossier photos").PageSetup.PrintArea = "A1:C" & derlignec

Range("A15").Select

End Sub

ou bien peut-être un ".value"

@ bientôt

LouReeD

J'ai testé la modification en variant le .Name, mais cela ne fonctionne pas