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

MISS_AJAZ

New Member
Joined
Jun 23, 2014
Messages
17
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 :)
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

Perpa

Well-known Member
Joined
Dec 18, 2012
Messages
635
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

Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,132,895
Messages
5,655,837
Members
418,246
Latest member
VerticalChris

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top