Excel VBA Inserting 3 pictures in different cells and Columns

Question

Hi Everybody

Hope you and yours are Ok at this awful time....

I Need your expertise to solve a small Pickle ....

Your above Code works almost for me.... but I need something slightly different....

I'm doing a work diary. Where I add everyday 3 to 9 PICS of works being done on my construction site.

I want to insert 3 images from a specific folder.  I want to select 3 image from my folder in one go!

When I use the code it should open the Folder automatically (Like ThisWorkbook.Path) the option "Application.GetOpenFilename" doesn't help me because I have to search every time the path of the folder. As my Pics and my sheet are in the same folder (everyday has different Pics and a copy of the same excel file), it would help to open it from there....

I have created a Botton, when I push it, it should:

Insert image 1, image 2 and image 3 (JPG, BMP, GIF, TIF, etc...)  in different columns. The 3 Pics should be selected in one selection (in the Folder) and being automatically copied to following cells:

Image 1 to Cell L82:P88

Image 2 to Cell Q82:U88

Image 3 to Cell V82:Z88

They should adjust Left/Top and in Height and Width in the Number of rows (3 Columns x 7 Lines)

Something like this:

1st Line

(PIC 1 = 3 Columns x 7 Lines) | (PIC 2 = 3 Columns x 7 Lines) | (PIC 3 = 3 Columns x 7 Lines)  End

2nd Line

(PIC 4 = 3 Columns x 7 Lines) | (PIC 5 = 3 Columns x 7 Lines) | (PIC 6 = 3 Columns x 7 Lines)  End

and so on... (don't worry I can easily copy and make a new Bottom for each Line....

I'm using some codes I found on the Net but can only get 1 image every-time in to the sheet... I don't want to have 1 Pic 1 Button.

Could you please help me. Thank you in advance for your help.

Daniel

Answer 1

Option Explicit

Sub Example_InsertPicture()

  Dim FName As String

  Dim i As Long, j As Long, k As Long, N As Long, S As Long

  Dim Where As Range, This As Range

  'We have to be sure that cells are selected

  If Not TypeOf Selection Is Range Then

    MsgBox "Select some cells where you want to insert the pictures and try again.", vbInformation, "Example_InsertPicture"

    Exit Sub

  End If

  With Application.FileDialog(msoFileDialogFilePicker)

    'Allow only pictures

    .Filters.Clear

    .Filters.Add "Pictures", "*.bmp;*.jpg;*.jpeg;*.png;*.gif"

    'Allow more then one picture to be inserted

    .AllowMultiSelect = True

    'Done if the user abort the dialog

    If Not .Show Then Exit Sub

    'Multiple pictures into the areas?

    If .SelectedItems.Count > Selection.Areas.Count Then

      Do

        N = Application.InputBox("How many pictures per area?", "Example_InsertPicture", .SelectedItems.Count \ Selection.Areas.Count, Type:=2)

        If N = 0 Then Exit Sub

      Loop Until N > 0

    Else

      N = 1

    End If

    'Perform max. possible pictures

    For i = 1 To Selection.Areas.Count

      Set Where = Selection.Areas(i)

      'Divide horizontally or vertically

      If Where.Height > Where.Width Then

        S = Where.Rows.Count \ N

        For j = 1 To N

          'Picture available?

          k = k + 1

          If k > .SelectedItems.Count Then Exit Sub

          'Where to place

          Set This = Where.Resize(S).Offset((j - 1) * S)

          'Insert into the sheet

          InsertPicture .SelectedItems(k), This

        Next

      Else

        S = Where.Columns.Count \ N

        For j = 1 To N

          'Picture available?

          k = k + 1

          If k > .SelectedItems.Count Then Exit Sub

          'Where to place

          Set This = Where.Resize(, S).Offset(, (j - 1) * S)

          'Insert into the sheet

          InsertPicture .SelectedItems(k), This

        Next

      End If

    Next

  End With

End Sub

Function InsertPicture(ByVal FName As String, ByVal Where As Range, _

    Optional ByVal LinkToFile As Boolean = False, _

    Optional ByVal SaveWithDocument As Boolean = True, _

    Optional ByVal LockAspectRatio As Boolean = True) As Shape

  'Inserts the picture file FName as link or permanently into Where

  Dim S As Shape, SaveScreenUpdating, SaveCursor

  SaveCursor = Application.Cursor

  SaveScreenUpdating = Application.ScreenUpdating

  Application.Cursor = xlWait

  Application.ScreenUpdating = False

  With Where

    'Insert in original size

    Set S = Where.Parent.Shapes.AddPicture( _

      FName, LinkToFile, SaveWithDocument, .Left, .Top, -1, -1)

    'Keep the proportions?

    S.LockAspectRatio = LockAspectRatio

    'Scale it to fit the cell

    S.Width = .Width

    If S.Height > .Height Or Not LockAspectRatio Then S.Height = .Height

    'Move it to the middle of the cells

    If S.Width < Where.Width Then S.Left = Where.Left + (Where.Width - S.Width) / 2

    If S.Height < Where.Height Then S.Top = Where.Top + (Where.Height - S.Height) / 2

  End With

  Set InsertPicture = S

  Application.Cursor = SaveCursor

  Application.ScreenUpdating = SaveScreenUpdating

End Function

Answer 2

Hi Andreas

Thank you for your reply.

Is it possible to have a Code where I push a Button and it Loads the Pictures auto form the exact Folder where my Excel Sheet is?

What I have....

Sub Photo1()

Dim fNameAndPath As Variant

Dim img As Picture

fNameAndPath = 'Should be This WorkBook (To open it directly without selecting Cells)

'Resize Picture to fit in the range....

.Left = ActiveSheet.Range("L82").Left

.Top = ActiveSheet.Range("L82").Top

.Width = ActiveSheet.Range("L82:P82").Width

.Height = ActiveSheet.Range("L82:L88").Height

.Placement = 1

.PrintObject = True

'Now I want to add the 2 other Pics but I don't know how! :(

.Left = ActiveSheet.Range("Q82").Left

.Top = ActiveSheet.Range("Q82").Top

.Width = ActiveSheet.Range("Q82:U82").Width

.Height = ActiveSheet.Range("Q82:Q88").Height

.Placement = 1

.PrintObject = True

.Left = ActiveSheet.Range("V82").Left

.Top = ActiveSheet.Range("V82").Top

.Width = ActiveSheet.Range("V82:Z82").Width

.Height = ActiveSheet.Range("V82:V88").Height

.Placement = 1

.PrintObject = True

End With

End Sub

Answer 3

​The Solution presented was not what I was searching.... meanwhile I got the solution after juggling with 2 Cods I found online.... (So Happy). Thank you to all for the help.