Macro to put pictures in shapes

[Xx7]

I have a folder of pictures. I would like to run a macro that creates a rectangle shape (see below) in every cell A1, A2... A100 for every picture. I would like to have each picture display in the background of their respective rectangle. Also, I would like to create a hyperlink to the shapes... so I can click on their rectangles and they will appear.

Any help appreciated!!



Here is some useful code to anchor the shapes to the cells:

 Sub Rectangle()

    
    With Range("b4")
        ActiveSheet.Shapes.AddShape _
                Type:=msoShapeRectangle, _
                Left:=.Left, _
                Top:=.Top, _
                Width:=.Width, _
                Height:=.Height


End With


 End Sub

 

[Xx7]

Here's some progress, this sets up a rectangle, imbeds the shape and sets-up a hyperlink.

Can somebody help me run a loop so that when I run the macro... it selects all files from a folder and then creates the following code for each.

Sub fslkdfj()
  
    With Range("b4")
        ActiveSheet.Shapes.AddShape _
                Type:=msoShapeRectangle, _
                Left:=.Left, _
                Top:=.Top, _
                Width:=.Width, _
                Height:=.Height
    End With
    ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .PresetTextured msoTexturePapyrus
        .TextureTile = msoTrue
        .TextureOffsetX = 0
        .TextureOffsetY = 0
        .TextureHorizontalScale = 1
        .TextureVerticalScale = 1
        .TextureAlignment = msoTextureTopLeft
    End With
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .UserPicture "C:\Users\BD\Desktop\Pics\Desert.jpg"
        .TextureTile = msoFalse
    End With
    ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:= _
        "C:\Users\BD\Desktop\Pics\Desert.jpg"



 End Sub

 

[NdNoviceHlp]

Here's a start. You need to make a loop for the pics in the folder and maybe others can help with the hyperlink thing. HTH. Dave

Sub fslkdfj()
'remove all existing shapes
'****caution code removes ALL shapes
Dim Sh As Shape, Fname As String, Cnt As Integer
Dim P As Object
With Sheets("Sheet1")
For Each Sh In .Shapes
If Sh.Type = msoPicture Then
Sh.Delete
End If
Next Sh
End With

'loop files pics here
Cnt = 0
'***For each pic in folder
Fname = "C:\Users\BD\Desktop\Pics\Desert.jpg"
Cnt = Cnt + 1

With Sheets("Sheet1").Range("A" & Cnt)
Set P = .Parent.Pictures.Insert(Fname)
 ' position picture
P.ShapeRange.LockAspectRatio = msoFalse
P.Top = .Top
P.Left = .Left
P.Width = .Width
P.Height = .Height
Set P = Nothing
End With
'****Next pic
End Sub

 

[NdNoviceHlp]

Had a bit more time. Here's the file loop. Dave

Sub fslkdfj()
'remove all existing shapes
'****caution code removes ALL shapes
Dim Sh As Shape, Fname As String, Cnt As Integer
Dim P As Object
With Sheets("Sheet1")
For Each Sh In .Shapes
If Sh.Type = msoPicture Then
Sh.Delete
End If
Next Sh
End With

'loop files pics here
Cnt = 0
Fname = Dir("C:\Users\BD\Desktop\Pics\", vbDirectory)
Do While Fname <> ""
Fname = Dir

If Right(Fname, 3) = "jpg" Then
Cnt = Cnt + 1
Fname = "C:\Users\BD\Desktop\Pics\" & Fname
With Sheets("Sheet1").Range("A" & Cnt)
Set P = .Parent.Pictures.Insert(Fname)
 ' position picture
P.ShapeRange.LockAspectRatio = msoFalse
P.Top = .Top
P.Left = .Left
P.Width = .Width
P.Height = .Height
Set P = Nothing
End With
End If

Loop
End Sub

 

[Xx7]

Nice!! thx. I will see if I can set the hyperlinks up when I have time.


Here's another question: Instead of having them all down column A, is there anyway to put the pictures down numerous columns A,B,C,D,& E? therefore, when I open the sheet I can view more pics across the screen.

So, if I had 25 pics... I would have pics in A1 to A5, B1 to B5... E1 to E5. Makes sense from a practical point of view, but probably tough to loop

 

[NdNoviceHlp]

It's usually better to specify your full needs to start with. An untested guess. Dave

Sub fslkdfj()
'remove all existing shapes
'****caution code removes ALL shapes
Dim Sh As Shape, Fname As String, Cnt As Integer
Dim P As Object, Cnt2 As Integer
With Sheets("Sheet1")
For Each Sh In .Shapes
If Sh.Type = msoPicture Then
Sh.Delete
End If
Next Sh
End With

'loop files pics here
Cnt = 0
Cnt2 = 1
Fname = Dir("C:\Users\BD\Desktop\Pics\", vbDirectory)
Do While Fname <> ""
Fname = Dir

If Right(Fname, 3) = "jpg" Then
If Cnt = 5 Then
Cnt2 = Cnt2 + 1
Cnt = 1
Else
Cnt = Cnt + 1
End If

Fname = "C:\Users\BD\Desktop\Pics\" & Fname
With Sheets("Sheet1").Cells(Cnt, Cnt2)
Set P = .Parent.Pictures.Insert(Fname)
 ' position picture
P.ShapeRange.LockAspectRatio = msoFalse
P.Top = .Top
P.Left = .Left
P.Width = .Width
P.Height = .Height
Set P = Nothing
End With
End If

Loop
End Sub

 

[Xx7]

Beauty... works great.

Is it tough to put the hyperlink through for each shape? I'm having abit of trouble looping.

ActiveSheet.Shapes.Range(Array("Picture 1")).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:= _
        "Pics\Desert.jpg"

 

[NdNoviceHlp]

Here's the hyperlink part. Note the change to the remove pictures part... that code didn't work for windows7 with XL10? Dave

Sub fslkdfj()
'remove all existing shapes
'****caution code removes ALL shapes
Dim Sh As Shape, Fname As String, Cnt As Integer
Dim P As Object, Cnt2 As Integer
With Sheets("Sheet1")
For Each Sh In .Shapes
If Sh.Type = 11 Then
Sh.Delete
End If
Next Sh
End With

'loop files pics here
Cnt = 0
Cnt2 = 1
Fname = Dir("C:\Users\BD\Desktop\Pics\", vbDirectory)
Do While Fname <> ""
Fname = Dir

If Right(Fname, 3) = "jpg" Then
If Cnt = 5 Then
Cnt2 = Cnt2 + 1
Cnt = 1
Else
Cnt = Cnt + 1
End If

Fname = "C:\Users\BD\Desktop\Pics\" & Fname
With Sheets("Sheet1").Cells(Cnt, Cnt2)
Set P = .Parent.Pictures.Insert(Fname)
.Hyperlinks.Add Anchor:=P.ShapeRange.Item(1), Address:=Fname
' position picture
P.ShapeRange.LockAspectRatio = msoFalse
P.Top = .Top
P.Left = .Left
P.Width = .Width
P.Height = .Height
Set P = Nothing
End With
End If

Loop
End Sub

 

[NdNoviceHlp]

edit: will re-post soon. Dave

 

[NdNoviceHlp]

One last kick at it. Apparently MS changed the msopicture constant for XL2010? HTH. Dave

Sub fslkdfj()
Dim Sh As Shape, Fname As String, Cnt As Integer
Dim P As Object, Cnt2 As Integer
'remove all existing shapes/pics
'****caution code removes ALL shapes
With Sheets("Sheet1")
For Each Sh In .Shapes
'if XL version > 07
If Application.Version > 12 Then
If Sh.Type = 11 Then
Sh.Delete
End If
Else
If Sh.Type = 13 Then
Sh.Delete
End If
End If
Next Sh
End With

'loop files pics here
Cnt = 0
Cnt2 = 1
Fname = Dir("C:\Users\BD\Desktop\Pics\", vbDirectory)
Do While Fname <> ""
Fname = Dir

If Right(Fname, 3) = "jpg" Then
If Cnt = 5 Then
Cnt2 = Cnt2 + 1
Cnt = 1
Else
Cnt = Cnt + 1
End If

Fname = "C:\Users\BD\Desktop\Pics\" & Fname
With Sheets("Sheet1").Cells(Cnt, Cnt2)
Set P = .Parent.Pictures.Insert(Fname)
.Hyperlinks.Add Anchor:=P.ShapeRange.Item(1), Address:=Fname
' position picture
P.ShapeRange.LockAspectRatio = msoFalse
P.Top = .Top
P.Left = .Left
P.Width = .Width
P.Height = .Height
Set P = Nothing
End With
End If

Loop
End Sub