Help! Need macro to insert multiple pics, resize and then fit into particular group of cells

[MISS_AJAZ]

Hi all,

Need help please...

The macro I have, opens the 'insert pic' dialogue box, allows user to only insert/select 1 pic, then a box pops up and confirms if you want to insert it, and then another box pops up and prompts you to specify which cell you want it inserting into, and it resizes it to the size I have specified in the macro.

I now need to edit it to change the following:

- Now to allow multiple pics to be inserted at the same time
- Position them into certain group of cells i.e. A1, A2, A3, A4, A5, etc.... (so basically each pic that has been inserted will go into each one of those cells, but somehow I need it to be endless because different users will insert different amount of pics).
- I want to remove the additional dialogue boxes that pop up.


This is my current code:

Sub INSERTPICANDRESIZE()

Dim Pict
Dim ImgFileFormat As String
Dim PictCell As Range
Dim Ans As Integer




ImgFileFormat = "jpg (*.jpg),*.jpg"




GetPict:
Pict = Application.GetOpenFilename(ImgFileFormat)
'Note you can load in any nearly file format
If Pict = False Then End




Ans = MsgBox("Open : " & Pict, vbYesNo, "Insert Picture")
If Ans = vbNo Then GoTo GetPict




'Now paste to userselected cell
GetCell:
Set PictCell = Application.InputBox("Select the cell to insert into", Type:=8)
If PictCell.Count > 1 Then MsgBox "Select ONE cell only": GoTo GetCell
PictCell.Select
ActiveSheet.Pictures.Insert(Pict).Select
Selection.ShapeRange.Height = 270.1417322835






End Sub

Please help.

Thank you

 

[Perpa]

Hi all,

Need help please...

The macro I have, opens the 'insert pic' dialogue box, allows user to only insert/select 1 pic, then a box pops up and confirms if you want to insert it, and then another box pops up and prompts you to specify which cell you want it inserting into, and it resizes it to the size I have specified in the macro.

I now need to edit it to change the following:

- Now to allow multiple pics to be inserted at the same time
- Position them into certain group of cells i.e. A1, A2, A3, A4, A5, etc.... (so basically each pic that has been inserted will go into each one of those cells, but somehow I need it to be endless because different users will insert different amount of pics).
- I want to remove the additional dialogue boxes that pop up.


This is my current code:

Sub INSERTPICANDRESIZE()

Dim Pict
Dim ImgFileFormat As String
Dim PictCell As Range
Dim Ans As Integer




ImgFileFormat = "jpg (*.jpg),*.jpg"




GetPict:
Pict = Application.GetOpenFilename(ImgFileFormat)
'Note you can load in any nearly file format
If Pict = False Then End




Ans = MsgBox("Open : " & Pict, vbYesNo, "Insert Picture")
If Ans = vbNo Then GoTo GetPict




'Now paste to userselected cell
GetCell:
Set PictCell = Application.InputBox("Select the cell to insert into", Type:=8)
If PictCell.Count > 1 Then MsgBox "Select ONE cell only": GoTo GetCell
PictCell.Select
ActiveSheet.Pictures.Insert(Pict).Select
Selection.ShapeRange.Height = 270.1417322835






End Sub

Please help.

Thank you

MISS_AJAZ,
This code will load ALL the pictures in the folder to the sheet you designate.
I copied it from the following link:
Excel-VBA : Insert Multiple Images from a Folder to Excel Cells
Perpa

Sub AddOlEObject()

    Dim mainWorkBook As Workbook
    Application.ScreenUpdating = False
    Set mainWorkBook = ActiveWorkbook
    Sheets("Object").Activate           'Change the sheet name from "Object" to the sheet name where you want your pictures to go
    Folderpath = "C:\Users\you\folder1"    'Change the folderpath to wherever your pictures are coming from
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
                counter = counter + 1
                Sheets("Object").Range("A" & counter).Value = fls.Name
                Sheets("Object").Range("B" & counter).ColumnWidth = 18     'Adjust to fit your pictures
                Sheets("Object").Range("B" & counter).RowHeight = 80           'Adjust to fit your pictures
                Sheets("Object").Range("B" & counter).Activate
                Call insert(strCompFilePath, counter)
                Sheets("Object").Activate
            End If
        End If
    Next
mainWorkBook.Save
Application.ScreenUpdating = True
End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 50      'Adjust to change the WIDTH of your pictures
            .Height = 70     'Adjust to change the HEIGHT of your pictures
        End With
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function