softman
04-15-2010, 05:36 AM
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.
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
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.
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