How to insert multiple pictures in order and resize?

Anonymous

I have the following macro that inserts a picture (using a new button created in the right mouse mutton menu that calls on "InsertPicAndResizeToCell") and resizes it to the selected cell or range of cells keeping the original aspect ratio.

This code works fine but now I would like to insert and resize multiple pictures at once instead of one by one.

The pictures should be inserted vertically, using a combobox filled from 1 to 3, either the cell directly below the active cell (where the first picture is inserted) or two or three cells below the previous one.

There is a post on the Office Word forum that answers (using WordBasic.SortArray) the question of keeping the order of multiple selections but I can not find a good solution that can be applied to Excel (jan 21, 2011). SortArray does apparently not apply to Excel.

So is there a way of keeping the order of selection (sorted on date or sorted on size or alphabeticaly) when beeing inserted?

Can someone please help me?

Thanks,

Frank

Private Sub InsertPicAndResizeToCell()

'with this macro (using the right mouse button) a picture can be inserted into the active cell

'the picture is resized into the cell keeping ratio

'where is the picture?

Call OpenExlorerFile

Dim oNewPic As Shape

' Dim Pic1 As Range 'does not work for some reason

On Error Resume Next

'cell or range of cells where the picture should be inserted:

Pic1 = Selection.Address

'Insert the picture:

Set oNewPic = ActiveSheet.Shapes.AddPicture(Filename:=strFileLoc, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _

Left:=Range(Pic1).Left + 0.5, Top:=Range(Pic1).Top + 0.5, Width:=Range(Pic1).Height, Height:=Range(Pic1).Height)

'Maintain original aspect ratio and set to full size

oNewPic.LockAspectRatio = msoTrue

oNewPic.ScaleHeight factor:=1, RelativeToOriginalSize:=msoTrue

oNewPic.ScaleWidth factor:=1, RelativeToOriginalSize:=msoTrue

' 'Resize the picture to fit in the destination cells

If (oNewPic.Width / oNewPic.Height) < (Range(Pic1).Width / Range(Pic1).Height) Then

oNewPic.Height = Range(Pic1).Height - 1.5

Else: oNewPic.Width = Range(Pic1).Width - 1.5

End If

End Sub

Sub OpenExlorerFile()

strFileLoc = Application.GetOpenFilename("All image files (*.JPG;*.BMP),*.JPG;*.BMP", 2)

End Sub

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments

Answer accepted by question author

Anonymous

2011-05-11T08:05:21+00:00

Curious.

I don't find that - Click the first, shift+click the last and they come in order.

But if you want to sort VPics that's easy enough.

You can use FileDateTime(vPics(I)) to get the date and time created.

Sub SortFiles(vFiles, Optional ByDate As Boolean)

Dim I As Integer

Dim J As Integer

Dim stTemp As String

Dim bSwap As Boolean

For I=LBound(vFiles) To UBound(vFiles)

    For J=I+1 To UBound(vFiles)

      If ByDate Then

        bSwap = FileDateTime(vFiles(J))<FileDateTime(vFiles(I))

      Else

        bSwap = vFiles(J)<vFiles(I)

      End If

      If bSwap Then

        stTemp = vFiles(J)

        vFiles(J)=vFiles(I)

        vFiles(I) = stTemp

      End If

    Next

Next

End Sub
Was this answer helpful?

1 person found this answer helpful.

0 comments No comments

Answer accepted by question author

Anonymous

2011-05-10T22:49:44+00:00

The following might be close to what you need.

It uses Application.GetOpenFilename to return multiple files.

You can sort the files how you like in the file open dialog.

Sub InsertPicAndResizeToCell()

'with this macro (using the right mouse button) a picture can be inserted into the active cell

'the picture is resized into the cell keeping ratio

'where are the pictures?

Dim vPics

Dim iPic As Integer

vPics = Application.GetOpenFilename("All image files (*.JPG;*.BMP),*.JPG;*.BMP", MultiSelect:=True)

If TypeName(vPics)="Boolean" Then Exit Sub ' cancelled

Dim oNewPic As Shape

Dim Pic1 As Range

'cell or range of cells where the picture should be inserted:

Set Pic1 = ActiveWindow.RangeSelection

For iPic = LBound(vPics) To UBound(vPics)

'Insert the picture:

Set oNewPic = ActiveSheet.Shapes.AddPicture(Filename:=vPics(iPic), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _

Left:=Pic1.Left + 0.5, Top:=Pic1.Top + 0.5, Width:=Pic1.Height, Height:=Pic1.Height)

'Maintain original aspect ratio and set to full size

oNewPic.LockAspectRatio = msoTrue

oNewPic.ScaleHeight factor:=1, RelativeToOriginalSize:=msoTrue

oNewPic.ScaleWidth factor:=1, RelativeToOriginalSize:=msoTrue

' 'Resize the picture to fit in the destination cells

If (oNewPic.Width / oNewPic.Height) < (Pic1.Width / Pic1.Height) Then

oNewPic.Height = Pic1.Height - 1.5

Else: oNewPic.Width = Pic1.Width - 1.5

End If

Set Pic1 = Pic1.Offset(Sheet1.ComboBox1.Value) ' replace Sheet1.ComboBox1 with reference to your combobox

Next

End Sub
Was this answer helpful?

0 comments No comments

11 additional answers

Anonymous

2011-05-11T15:18:57+00:00

I don't know why we get different results from selecting multiple files, but anyway, if you want them in either alphabetical or date order you could use the sort procedure I supplied.

If you want some arbitrary order then of course it can't be done by program.
Was this answer helpful?

0 comments No comments
Anonymous

2011-05-11T14:23:07+00:00

Again usefull and used in the new code but I'm still puzzled about the sorting part.

On my pc and others aswell always the same problem of importing the last selected file first and just then starting at the top of the list.

I adapted your code so that the last selected file is moved to the top of the list. This works fine if every user (not me) selects the first file in the list and then using shift+click the last. The code below can handle this, but if I use ctrl+A then all is lost. The order of selection isn't respected anymore.

If I look closely at the file open dialog I see the the last clicked file has dotted lines arround it.

Can this be a part of the problem? This dotted line is different when I use ctrl+A or when I use Shift+click.

What I have so far is:

Private Sub InsertPicAndResizeToCell()

'with this macro (using the right mouse button) a picture can be inserted into the active cell

'the picture is resized into the cell keeping ratio

Dim oNewPic As Shape

Dim strAantalPicJumps As Single

Dim stTemp As String

On Error Resume Next

Pic1 = Selection.Address

'Get Pics:

vPics = Application.GetOpenFilename("All image files (*.JPG;*.BMP),*.JPG;*.BMP", Title:="Select the pictures from top to bottom", MultiSelect:=True)

If TypeName(vPics) = "Boolean" Then Exit Sub ' cancelled

'If more than 1 selection is made then use this value to jump

'to the next location at the end of importing the previous picture

'It is important to make a top down selection!!

If UBound(vPics) > 1 Then UserForm3.Show

strAantalPicJumps = UserForm3.cbxFotoJump

'move the last selected picture to the front of the line

I = 1

For J = I + 1 To UBound(vPics)

    stTemp = vPics(J)

    vPics(J) = vPics(I)

    vPics(I) = stTemp

    I = I + 1

Next J

'Insert the picture in order:

For I = LBound(vPics) To UBound(vPics)

    'Insert the picture:

    Set oNewPic = ActiveSheet.Shapes.AddPicture(Filename:=vPics(I), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _

    Left:=Range(Pic1).Left + 0.5, Top:=Range(Pic1).Top + 0.5, Width:=Range(Pic1).Height, Height:=Range(Pic1).Height)

    'Maintain original aspect ratio and set to full size

    oNewPic.LockAspectRatio = msoTrue

    oNewPic.ScaleHeight factor:=1, RelativeToOriginalSize:=msoTrue

    oNewPic.ScaleWidth factor:=1, RelativeToOriginalSize:=msoTrue

    'Resize the picture to fit in the destination cells

    If (oNewPic.Width / oNewPic.Height) < (Range(Pic1).Width / Range(Pic1).Height) Then

        oNewPic.Height = Range(Pic1).Height - 1.5

    Else: oNewPic.Width = Range(Pic1).Width - 1.5

    End If

    'Assign the desired name to the picture

    oNewPic.Name = Dir(vPics(I), vbDirectory)

    ActiveCell.Range("A1") = Dir(vPics(I), vbDirectory)

    'If more than 1 selection of pics is made then jump to next location

    If UBound(vPics) > 1 Then

        ActiveCell.Offset(strAantalPicJumps, 0).Select

        Pic1 = Selection.Address

    End If

Next I

End Sub
Was this answer helpful?

0 comments No comments
Anonymous

2011-05-11T07:35:29+00:00

This is a solution to the multiselect problem but somehow I don't seem te get the pictures imported in the correct order. The last selected picture always gets imported first.

The LBound and UBound functions seem to return a Long that is not linked to the picture names, and so do not sort alphabeticaly (or keep an other sorted order).

Is there a function/method (or anything else) that can sort the variant VPics in different ways? (by date or size or alphabeticaly or ....?)
Was this answer helpful?

0 comments No comments

Share via

How to insert multiple pictures in order and resize?

11 additional answers