How to make an image grid from hyperlinks in Excel

[jhbendeck]

Hello, good afternoon. Hope all of you are doing great.

I am opening this post to know how to generate a picture grid (the final product could be a picture format) from a list of hyperlinks (each link contains an image) in an Excel file. This is an example (Attach sample file as reference here):

And the final product of this grid should look like this:

Where the word MARATON stays and the only information to add is the following (above or below the collage) (The background could be a black or white color), organized as a 9x9 grid:

Team Name (with a 22-24 font size)

Name of the Captain: First member of the team (For example: In the excel file, Maribel Sharpe is the captain)

Lap Number ____ (This lap number can be edited manually)
​

If there is any additional information to be added, please let me know and thanks in advance for all your support.

Kind regards,

Juan.

 

[Colo]

Hi, juan

For downloading images, URLDownloadToFile Function of Windows API can be used. Then add images by Shapes.AddPicture method to a worksheet. After having images on a sheet, adding and adjusting shapes work would be needed.

Also, need to know the final size of the grid and order how to place the images in the grid.
Example: image# 1 to image#3 are placed left to right then image#4 starts on the next row.

There is a case, all the complete codes would be posted by somebody, but I recommend you to ask about just what is necessary for what you want.

 

[Colo]

Sorry, time is up. But I believe that downloading and adding images part works with this sample code. This code makes a temporary worksheet named TEMP and put images in there.

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, _
                                                                                                ByVal szURL As String, _
                                                                                                ByVal szf As String, _
                                                                                                ByVal dwReserved As Long, _
                                                                                                ByVal lpfnCB As LongPtr) As LongPtr
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
                                                                                        ByVal szURL As String, _
                                                                                        ByVal szf As String, _
                                                                                        ByVal dwReserved As Long, _
                                                                                        ByVal lpfnCB As Long) As Long
#End If

Sub MakeImageGgrids()
'Sample code
    Dim blnDl As Boolean    'A flag if the download has succeed
    Dim i As Long, j As Long
    Dim f As String, n, sPath As String
    Dim a As Variant, b()
    Dim Shp As Shape, Nlabel As Shape, p9(1 To 9), k As Long
    Dim pLeft As Double, pTop As Double
    Const pSize As Double = 80    ' Change size to suit your needs

    Application.ScreenUpdating = False

    sPath = Environ("TEMP") & "\"

    a = ThisWorkbook.Worksheets("Hoja1").Range("A2:C136").Value

    For j = LBound(a, 1) To UBound(a, 1)
        n = Split(a(j, 3), "/")
        f = n(UBound(n))
        blnDl = URLDownloadToFile(0, a(j, 3), sPath & f, 0, 0) = 0
        If blnDl Then
            ReDim Preserve b(i)
            b(i) = sPath & f
            i = i + 1
        End If
    Next

    Application.DisplayAlerts = False
    On Error Resume Next: Sheets("Temp").Delete: On Error GoTo 0
    Application.DisplayAlerts = True
    ThisWorkbook.Sheets.Add.Name = "Temp"

    For i = LBound(b) To UBound(b)
        Select Case (i + 1) Mod 3
        Case 0: pLeft = pSize * 2
        Case 1: pLeft = 0
        Case 2: pLeft = pSize
        End Select
        Set Shp = ActiveSheet.Shapes.AddPicture _
                  (FileName:=b(i), LinkToFile:=False, SaveWithDocument:=True, Left:=pLeft, Top:=pTop, Width:=pSize, Height:=pSize)
        Shp.Name = i & "picture"
        Set Nlabel = ActiveSheet.Shapes.AddShape(msoShapeRectangle, pLeft, pTop + pSize * 0.8, pSize, pSize * 0.2)
        Nlabel.ShapeStyle = msoShapeStylePreset38
        Nlabel.TextFrame2.TextRange.Characters.Text = a(i + 1, 2)    'Name label
        Nlabel.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        Nlabel.Name = i & "name"
        ActiveSheet.Shapes.Range(Array(Shp.Name, Nlabel.Name)).Group.Name = "Group" & i      'Group Photos and Name label
        k = k + 1
        p9(k) = ActiveSheet.Shapes("Group" & i).Name
        If k = 9 Then
            ActiveSheet.Shapes.Range(p9).Group
            k = 0
        End If
        If (i + 1) Mod 3 = 0 Then pTop = pTop + pSize
    Next

    Application.ScreenUpdating = True
    MsgBox "making a sample has been done."
End Sub

 

[Colo]

Anyway, just I've had fun with this. It works on the attached sample file.

'https://www.mrexcel.com/board/threads/how-to-make-an-image-grid-from-hyperlinks-in-excel.1212616/
'
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, _
                                                                                                ByVal szURL As String, _
                                                                                                ByVal szf As String, _
                                                                                                ByVal dwReserved As Long, _
                                                                                                ByVal lpfnCB As LongPtr) As LongPtr
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
                                                                                        ByVal szURL As String, _
                                                                                        ByVal szf As String, _
                                                                                        ByVal dwReserved As Long, _
                                                                                        ByVal lpfnCB As Long) As Long
#End If

Sub MakeImageGgrids()
    Dim blnDl As Boolean    'A flag if the download has succeed
    Dim i As Long, j As Long
    Dim f As String, n, sPath As String
    Dim a As Variant, b()
    Dim shp As Shape, Nlabel As Shape, p9(1 To 9), k As Long
    Dim pLeft As Double, pTop As Double
    Const pSize As Double = 56    ' Change size to suit your needs

    Application.StatusBar = False
    Application.ScreenUpdating = False

    sPath = Environ("TEMP") & "\"

    Application.DisplayAlerts = False
    On Error Resume Next: Sheets("Temp").Delete: On Error GoTo 0
    Application.DisplayAlerts = True
    ThisWorkbook.Sheets.Add.Name = "Temp"
    a = ThisWorkbook.Worksheets("Hoja1").Range("A2:C136").Value

    For j = LBound(a, 1) To UBound(a, 1)
        n = Split(a(j, 3), "/")
        f = n(UBound(n))
        Application.StatusBar = j & " / " & UBound(a, 1)
        DoEvents
        blnDl = URLDownloadToFile(0, a(j, 3), sPath & f, 0, 0) = 0
        If blnDl Then
            ReDim Preserve b(i)
            b(i) = sPath & f
            i = i + 1
        End If
    Next

    For i = LBound(b) To UBound(b)
        Select Case (i + 1) Mod 3
        Case 0: pLeft = pSize * 2
        Case 1: pLeft = 0
        Case 2: pLeft = pSize
        End Select
        Set shp = ActiveSheet.Shapes.AddPicture _
                  (FileName:=b(i), LinkToFile:=False, SaveWithDocument:=True, Left:=pLeft, Top:=pTop, Width:=pSize, Height:=pSize)
        shp.Name = i & "picture"

        shp.Line.Visible = msoTrue
        shp.Line.Weight = 1.5
        shp.Line.ForeColor.RGB = RGB(255, 255, 255)

        Set Nlabel = ActiveSheet.Shapes.AddShape(msoShapeRectangle, pLeft, pTop + pSize * 0.8, pSize, pSize * 0.2)
        Nlabel.ShapeStyle = msoShapeStylePreset38
        Nlabel.TextFrame2.TextRange.Characters.Text = a(i + 1, 2)    'Name label
        Nlabel.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        Nlabel.TextFrame2.VerticalAnchor = msoAnchorMiddle
        Nlabel.TextFrame2.TextRange.Font.Size = 7
        Nlabel.Name = i & "name"
        ActiveSheet.Shapes.Range(Array(shp.Name, Nlabel.Name)).Group.Name = "Group" & i      'Group Photos and Name label

        If i = 0 Or (i + 9) Mod 9 = 0 Then
            Call MarkCaptain(shp.Top + shp.Height - 30)
            ActiveSheet.Shapes.Range(Array("Group" & i, Selection.Name)).Group.Name = "Group" & i
        End If

        k = k + 1
        p9(k) = ActiveSheet.Shapes("Group" & i).Name

        If k = 9 Then
            Dim face, y As Double, bgHeight As Double
            Set face = ActiveSheet.Shapes.Range(p9).Group

            'Make Background
            Call MakingBG(a(i + 1, 1))    'Team Flag
            face.IncrementTop 80
            face.IncrementLeft 40
            face.ZOrder msoBringToFront
            y = y + 1
            Selection.ShapeRange.IncrementTop Selection.Height * (y - 1)
            bgHeight = Selection.Height
            k = 0
        End If
        If (i + 1) Mod 9 = 0 Then
            pTop = pTop + pSize + (bgHeight - (pSize * 3))
        ElseIf (i + 1) Mod 3 = 0 Then
            pTop = pTop + pSize
        End If
    Next

    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox "making a sample has been done."
End Sub

Sub MarkCaptain(ByVal dTop As Double)
    Dim shpCir
    Const dCirSize As Double = 16.5
    Set shpCir = ActiveSheet.Shapes.AddShape(msoShapeOval, 0, dTop, dCirSize, dCirSize)
    With shpCir.TextFrame2.TextRange
        .Characters.Text = "C"
        .Font.Name = "Arial"
        .Font.Size = 8
        .ParagraphFormat.Alignment = msoAlignCenter
        .Parent.VerticalAnchor = msoAnchorMiddle
    End With
    With shpCir.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(192, 0, 0)
        .Transparency = 0
        .Solid
    End With
    shpCir.Select
End Sub

Sub MakingBG(ByVal sTeams As String)
    Dim shpBg
    Dim shpBglabel
    Dim shpTeam
    Dim shpBgTri As Object    'Background Triangle
    Dim Txb1 As Shape, Txb2 As Shape
    Dim tmpGroup(0 To 7), s

    Set shpBg = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 257.25, 290.25)
    shpBg.Fill.Visible = msoTrue    'Background
    shpBg.Fill.ForeColor.RGB = RGB(255, 255, 255)
    shpBg.Line.Visible = msoFalse
    tmpGroup(0) = shpBg.Name

    Set shpBgTri = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 0, 0)
    shpBgTri.AddNodes msoSegmentLine, msoEditingAuto, 0, 225
    shpBgTri.AddNodes msoSegmentLine, msoEditingAuto, 257.25, 70
    shpBgTri.AddNodes msoSegmentLine, msoEditingAuto, 257.25, 0
    shpBgTri.AddNodes msoSegmentLine, msoEditingAuto, 0, 0

    Set s = shpBgTri.ConvertToShape
    s.Fill.Visible = msoTrue
    s.Line.Visible = msoFalse
    s.Fill.ForeColor.RGB = RGB(245, 185, 161)
    tmpGroup(1) = s.Name

    Set shpBgTri = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 0, 225)
    shpBgTri.AddNodes msoSegmentLine, msoEditingAuto, 0, 290.25
    shpBgTri.AddNodes msoSegmentLine, msoEditingAuto, 70, 225
    shpBgTri.AddNodes msoSegmentLine, msoEditingAuto, 0, 225
    Set s = shpBgTri.ConvertToShape
    s.Fill.Visible = msoTrue
    s.Line.Visible = msoFalse
    s.Fill.ForeColor.RGB = RGB(245, 185, 161)
    tmpGroup(2) = s.Name

    Set shpBgTri = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 225, 290.25)
    shpBgTri.AddNodes msoSegmentLine, msoEditingAuto, 257.25, 290.25
    shpBgTri.AddNodes msoSegmentLine, msoEditingAuto, 257.25, 255
    shpBgTri.AddNodes msoSegmentLine, msoEditingAuto, 225, 290.25
    Set s = shpBgTri.ConvertToShape
    s.Fill.Visible = msoTrue
    s.Line.Visible = msoFalse
    s.Fill.ForeColor.RGB = RGB(245, 185, 161)
    tmpGroup(3) = s.Name

    Set shpBglabel = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 257.25, 35.25)
    shpBglabel.Fill.Visible = msoTrue    'Title label
    shpBglabel.Fill.ForeColor.RGB = RGB(86, 169, 61)
    shpBglabel.Line.Visible = msoFalse
    shpBglabel.TextFrame2.TextRange.Characters.Text = "MARATON"    'Title label
    shpBglabel.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    shpBglabel.TextFrame2.VerticalAnchor = msoAnchorMiddle
    shpBglabel.TextFrame2.TextRange.Font.Size = 24
    shpBglabel.TextFrame2.TextRange.Font.Name = "Arial"
    tmpGroup(4) = shpBglabel.Name

    Set shpTeam = ActiveSheet.Shapes.AddShape(msoShapeWave, 90, 42, 80, 30)
    shpTeam.Fill.Visible = msoTrue    'Team Name Flag
    shpTeam.Fill.ForeColor.RGB = RGB(140, 195, 78)
    shpTeam.Line.Visible = msoTrue
    shpTeam.Line.Weight = 0.5
    shpTeam.TextFrame2.TextRange.Characters.Text = sTeams    'Team Name
    shpTeam.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    shpTeam.TextFrame2.VerticalAnchor = msoAnchorMiddle
    shpTeam.TextFrame2.TextRange.Font.Size = 12
    shpTeam.TextFrame2.TextRange.Font.Name = "Elephant"
    tmpGroup(5) = shpTeam.Name

    Set Txb1 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 40, 252, 84, 11.25)
    Txb1.TextFrame2.TextRange.Characters.Text = "Equipo Jjamando 11"
    Txb1.TextFrame2.TextRange.Font.Size = 8
    Txb1.Line.Visible = msoFalse
    tmpGroup(6) = Txb1.Name

    Set Txb2 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 40, 270, 84, 11.25)
    Txb2.TextFrame2.TextRange.Characters.Text = "Vuelta 2"
    Txb2.TextFrame2.TextRange.Font.Size = 8
    Txb2.Line.Visible = msoFalse
    tmpGroup(7) = Txb2.Name
    ActiveSheet.Shapes.Range(tmpGroup).Group.Select
End Sub