Macro to insert multiple images at specific cells and resize all i

[Mike Charlie Charlie]

Hi,

I am trying to write a macro which will prompt a user to select multiple
images ,from a folder of their choice. The macro then needs to insert the
images at eqaul intervals ie C3, C48, C93 and so on an finally resize the
images to 19% of their original size.

I have found some examples for inserting images into worksheets and have
enabled selection of multiple files/images but all of the images or then
inserted into the one cell that is selected as the insertion point. At
present the insertion cell is selected by the user but I want to make the
cells for insertion mandatory.

Below is the code thus far.

Sub Insert_Pict()

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

ActiveSheet.Protect False, False, False, False, False
ImgFileFormat = "Image Files (*.bmp),others, tif (*.tif),*.tif, jpg
(*.jpg),*.jpg"

GetPict:
Pict = Application.GetOpenFilename(ImgFileFormat, MultiSelect:=True)
'Note you can load in any nearly file format
If Not IsArray(Pict) Then
Debug.Print "No files selected."
Exit Sub
End If

'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


End Sub

Any help appreciated greatly.
MCC.

 

[Barb Reinhardt]

I'd tweak this section, but I haven't looked at the entire bit of code.

'Now paste to userselected cell

Do
Set PictCell = Application.InputBox("Select the cell to insert into",
Type:=8)
Loop while PictCell.count <> 1

PictCell.Select
ActiveSheet.Pictures.Insert(Pict).Select