Nice image import code

[softman]

I have found this nice image import code but could not remember where but like to share it.

How it works:
1. Select your image folder
2. Select your image names to be imported
2. Select the placement of the images
3. Run the macro

The only small issue I have picked up with this is that the button (calling the macro) must be in the same worksheet of the import. If not the images does not get placed as your wish.

[VBA]Sub Pictures()
Call Pic1
Call Pic2
Call Pic3
End Sub
Sub Pic1()
InsertPictureInRange1 "C:\images\1.jpg", _
Range("B5:G24")
End Sub
Sub InsertPictureInRange1(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(Sheet2) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = Sheet2.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub

Sub Pic2()
InsertPictureInRange2 "C:\images\2.jpg", _
Range("B27:H46")
End Sub
Sub InsertPictureInRange2(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(Sheet2) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = Sheet2.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub

Sub Pic3()
InsertPictureInRange3 "C:\images\2.jpg", _
Range("I5:O24")
End Sub
Sub InsertPictureInRange3(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(Sheet2) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = Sheet2.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub
[/VBA]

[p45cal]

I don't see the differences between InsertPictureInRange1, InsertPictureInRange2 and InsertPictureInRange3. If I'm not wrong then the code can be:
1. shortened
2. adjusted to cope with which sheets you want the pictures in and
3. adjusted to be independent of the active sheet:
[vba]Sub Pictures()
InsertPictureInRange1 "C:\images\1.jpg", Sheets("A sheet").Range("B5:G24")
InsertPictureInRange1 "C:\images\2.jpg", Sheets("Another Sheet").Range("B27:H46")
InsertPictureInRange1 "C:\images\2.jpg", Sheets("A third Sheet").Range("I5:O24")
End Sub
Sub InsertPictureInRange1(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object
With TargetCells
If TypeName(.Parent) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = .Parent.Pictures.Insert(PictureFileName)
' position picture
p.Top = .Top
p.Left = .Left
p.Width = .Offset(0, .Columns.Count).Left - .Left
p.Height = .Offset(.Rows.Count, 0).Top - .Top
End With
Set p = Nothing
End Sub
[/vba]ok, I'm being a smart arse

[mdmackillop]

ok, I'm being a smart arse

Best kind to be!!!

[p45cal]

I didn't test this at all before posting but on testing in xl2007, I noticed that the jpegs weren't placed correctly, only because when adjusting the last dimension (height) my jpg was being adjusted while retaining width/height proportion. So everything but the width ended up being correct.
While trying to record a macro of my resizing the picture, xl2007 recorded nothing. So on to the laptop which has xl2003. It produced code with the likes of scaleheight and scalewidth where I'd have to specify whether it's relative to the original or the current size, and which part of the image keeps its position. A lot of workiing out to do.
Then I ran the macro above in xl2003 and guess what? The image had been placed in exactly the desired position, even though, on both systems, the 'Lock aspect ratio' checkbox for the image showed as ticked.
So xl2007 behaves differently - perhaps I should've known.
This was solved by the addition of:
[vba]p.ShapeRange.LockAspectRatio = msoFalse[/vba] Anyway, while wandering I came across a way of simplifying a bit more. The lines:
[vba]p.Width = .Offset(0, .Columns.Count).Left - .Left
p.Height = .Offset(.Rows.Count, 0).Top - .Top [/vba] can be shortened to:
[vba]p.Width = .Width
p.Height = .Height[/vba] leaving the macro now as:
[vba]Sub InsertPictureInRange1(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object
With TargetCells
If TypeName(.Parent) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = .Parent.Pictures.Insert(PictureFileName)
' position picture
p.ShapeRange.LockAspectRatio = msoFalse 'for excel 2007
p.Top = .Top
p.Left = .Left
p.Width = .Width
p.Height = .Height
End With
Set p = Nothing
End Sub[/vba]

[softman]

Great improvment and much faster. Many thanks for shareing your knowledge.

[Vette1965]

Perhaps one of you can tell me whats wrong with my code. It does everything well except that the heigth is not coming in correctly. I even try to record but 2007excel it can't be seen.

Welcome to any ideas

[vba]
Sub AddImages()
Dim strPath As String
Dim strFile As String
Dim Picture As Object
Dim Response As String
Dim A As Range

strPath = "C"

For Each A In Range("a1", Range("A65536").End(xlUp))
If A <> 0 Then
With A.Offset(0, 2)
Set Picture = Nothing
On Error Resume Next
Set Picture = Sheets("Raw Pix").Pictures.Insert(strPath & A.Value & ".jpg")
Picture.ShapeRange.LockAspectRatio = msoFalse
Picture.Placement = xlMoveAndSize
Picture.Top = .Top
Picture.Left = .Left
Picture.Height = 122
Picture.Width = 149



End With
End If
Next A

End Sub[/vba]

Thanks in advance!

[p45cal]

I've tried to reproduce the height problem but get no problem at all. What exactly is the height problem?

[Vette1965]

I sent the file so you can see it how the macro is doing. On the spread sheet each row is the same width and the two columns the photos reside are in same width as well. I do know that the first photo does line up in the top left corner. But for each subsequent photo, the photos are slightly below the top left corner for each range.

Should I identify each cell range the photo should reside instead of telling it where go to in the code?

A.Offset(0, 2)

Thanks

[p45cal]

So it's the top of each picture which is at fault rather than the height.
I wonder whether the addition of the images changes the height of some of the rows because there's auto-wrapping going on?
Step throught the code (F8) observing what happens and identify when the picture is losing its position or never getting into the right position.
One thing you might try is instead of:
[vba]Picture.Height = 122
Picture.Width = 149[/vba]use:
[vba]Picture.Height = .Resize(4).Height
Picture.Width = .Resize(2).Width[/vba]

[Vette1965]

What do you mean by wrapping?

[p45cal]

Format Cells|Alignment tab|Wrap Text

[Vette1965]

Well I think I found the solution but not very happy how I got it. After using your, p45cal, idea about using F8 I ran the macro a lot of times and noticed that it wasn't really a top left issue more a height issue. After many runs this is the solution. My excel page has to be at 100% AND each row has to be at 31.5 (42 pixels)... I used these figures in the code

[VBA] Picture.Height = 126
Picture.Width = 149[/VBA]

Now each photo is perfectly flush as it was in 2003 excel.

I got to add some lines to make sure the zoom & row height are always correct but it beats not running the report at all.

If anybody has any suggestions on this zoom & height problem it would be much appreciated by me and all.

Thanks a lot p45cal!

James

[mdmackillop]

Can you zip and post a pictures file?

To fix what you have, try
[vba]
Sub Macro1()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
Set c = sh.TopLeftCell
If c.Column = 3 Then
sh.Top = c.Offset(, -1).MergeArea.Top
sh.Height = c.Offset(, -1).MergeArea.Height
End If
Next
End Sub

[/vba]
You could even squeeze the images to maintain the borders
[VBA]
Sub Macro2()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
Set c = sh.TopLeftCell
If c.Column = 3 Then
sh.Top = c.Offset(, -1).MergeArea.Top + 2
sh.Height = c.Offset(, -1).MergeArea.Height - 4
End If
Next
End Sub

[/VBA]