Insert Multiple pictures

[ardykav]

I would like to insert multiple pictures onto a worksheet, there will be a max of 6 pictures starting at Cell A1 and then in intervals of 19 Rows. So A1, A20, A39 etc.

Just having a bit of difficulty with Selecting multiple files at once and placing them in the relevant cells. This is the code I am using

Sub GetPic()
Dim fNameAndPath As Variant
Dim img As Picture
Sheets("Sign Off").Select
fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
If fNameAndPath = False Then Exit Sub
    Set img = Sheets("Photos").Pictures.Insert(fNameAndPath)
    With img
       Sheets("Photos").Select
       .Left = Range("A1").Left
       .Top = Range("A1").Top
       .Width = Range("A1:D1").Width
       .Height = Range("A1:D18").Height
       .Placement = 1
       .PrintObject = True
    End With
End Sub

Once its all inserted I want to PDF and then clear the tab but I think I have that part sorted,

thanks in advance

 

[Domenic]

Try the following macro...

Option Explicit

Sub GetPics()

    Dim selected_filenames As Variant
    selected_filenames = Application.GetOpenFilename( _
        FileFilter:="Image Files (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
        Title:="Select Pictures To Be Imported", _
        MultiSelect:=True)
    
    If Not IsArray(selected_filenames) Then Exit Sub

    Dim destination_sheet As Worksheet
    Set destination_sheet = Worksheets("Photos")

    Dim current_image As Picture
    Dim i As Long
    For i = LBound(selected_filenames) To UBound(selected_filenames)
        Set current_image = destination_sheet.Pictures.Insert(selected_filenames(i))
        With current_image
            .ShapeRange.LockAspectRatio = msoFalse
            .Left = destination_sheet.Range("A1").Offset(i * 19 - 19).Left
            .Top = destination_sheet.Range("A1").Offset(i * 19 - 19).Top
            .Width = destination_sheet.Range("A1:D18").Offset(i * 19 - 19).Width
            .Height = destination_sheet.Range("A1:D18").Offset(i * 19 - 19).Height
            .Placement = 1
            .PrintObject = True
        End With
    Next i

    destination_sheet.Activate

End Sub

Note that I have added a filter for the GetOpenFilename method so that only image files are listed. Change and/or add to the filter as desired.

Also note that the MultiSelect property is set to True to allow the user to select multiple files.

Hope this helps!

 

[ardykav]

Works an absolute charm thank you so much

Try the following macro...

Option Explicit

Sub GetPics()

    Dim selected_filenames As Variant
    selected_filenames = Application.GetOpenFilename( _
        FileFilter:="Image Files (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
        Title:="Select Pictures To Be Imported", _
        MultiSelect:=True)
   
    If Not IsArray(selected_filenames) Then Exit Sub

    Dim destination_sheet As Worksheet
    Set destination_sheet = Worksheets("Photos")

    Dim current_image As Picture
    Dim i As Long
    For i = LBound(selected_filenames) To UBound(selected_filenames)
        Set current_image = destination_sheet.Pictures.Insert(selected_filenames(i))
        With current_image
            .ShapeRange.LockAspectRatio = msoFalse
            .Left = destination_sheet.Range("A1").Offset(i * 19 - 19).Left
            .Top = destination_sheet.Range("A1").Offset(i * 19 - 19).Top
            .Width = destination_sheet.Range("A1:D18").Offset(i * 19 - 19).Width
            .Height = destination_sheet.Range("A1:D18").Offset(i * 19 - 19).Height
            .Placement = 1
            .PrintObject = True
        End With
    Next i

    destination_sheet.Activate

End Sub

Note that I have added a filter for the GetOpenFilename method so that only image files are listed. Change and/or add to the filter as desired.

Also note that the MultiSelect property is set to True to allow the user to select multiple files.

Hope this helps!

 

[Domenic]

That's great, glad I could help.

Cheers!