Macro to insert 4 images per page, picture name, picture reference and additional row

Hello, I've not used VBA in any detail before and now a little out of my depth. I'm trying to modify the code from another post (

Macro to insert 4 pictures per page, picture name, picture references

) for my intended application.

The changes I'm trying to make are;

• Turn gridline on for the whole table
• Reduce the white space below the images themselves, row height to be 6 cm
• Insert additional row below the figure caption so that I can add a description to the images

Attachment 20174
Any help would be appreciated.

Code:

---

Option Explicit
Dim oTbl As Table
Sub AddPics()
    Dim lngIndex As Long, lngRowIndex As Long, lngCellIndex As Long, strTxt As String
    Dim oRng As Range
    Dim oRow As Row
    Application.ScreenUpdating = False
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select image files and click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        If .Show = -1 Then
            InsertFittedTable
            For lngIndex = 1 To .SelectedItems.Count
                lngRowIndex = Int((lngIndex + 1) / 2) * 3 - 1
                lngCellIndex = (lngIndex - 1) Mod 2 + 1
                'Add extra rows as needed
                If lngRowIndex > oTbl.Rows.Count Then
                    Set oRng = oTbl.Rows.Last.Cells(1).Range
                    oRng.Collapse wdCollapseStart
                    oRng.Select
                    Selection.InsertRowsBelow 6
                    oTbl.Rows(oTbl.Rows.Count - 1).Height = oTbl.Rows(oTbl.Rows.Count - 7).Height
                    oTbl.Rows(oTbl.Rows.Count - 4).Height = oTbl.Rows(oTbl.Rows.Count - 10).Height
                End If
                'Insert the Picture
                ActiveDocument.InlineShapes.AddPicture _
                FileName:=.SelectedItems(lngIndex), LinkToFile:=False, _
                SaveWithDocument:=True, Range:=oTbl.Rows(lngRowIndex).Cells(lngCellIndex).Range
                'Get the Image name for the Caption
                strTxt = Split(.SelectedItems(lngIndex), "\")(UBound(Split(.SelectedItems(lngIndex), "\")))
                'Insert the Caption on the row above the picture
                oTbl.Rows(lngRowIndex - 1).Cells(lngCellIndex).Range.Text = Split(strTxt, ".")(0)
                Set oRng = oTbl.Rows(lngRowIndex + 1).Cells(lngCellIndex).Range
                oRng.Text = "Figure - "
                oRng.Collapse wdCollapseEnd
                oRng.End = oRng.End - 1
                ActiveDocument.Fields.Add oRng, wdFieldSequence, "Number"
            Next
        End If
    End With
    ActiveDocument.Fields.Update
    Do While Len(oTbl.Rows.Last.Range) = 6
        oTbl.Rows.Last.Delete
    Loop
    Application.ScreenUpdating = True
lbl_Exit:
    Exit Sub
End Sub
Sub InsertFittedTable()
    Dim oRow As Row
    Set oTbl = Selection.Tables.Add(Selection.Range, 6, 2)
    oTbl.AutoFitBehavior (wdAutoFitFixed)
    For Each oRow In oTbl.Rows
        With oRow
            .Height = CentimetersToPoints(0.75)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Normal"
            .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        End With
    Next oRow
    Do
        oTbl.Rows(2).Height = oTbl.Rows(2).Height + 5
        oTbl.Rows(5).Height = oTbl.Rows(2).Height
    Loop Until oTbl.Rows(6).Range.Information(wdActiveEndPageNumber) > oTbl.Rows(1).Range.Information(wdActiveEndPageNumber)
    ActiveDocument.Undo 2
End Sub

---

Thank-you.

See http://www.gmayor.com/photo_gallery_template.html

Ideally after something macro based rather than an add-on

Try the following, which is a minor variation on http://www.vbaexpress.com/forum/show...=1#post306321:

Code:

---

Sub AddPics()
    Application.ScreenUpdating = False
    Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
    Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
    On Error GoTo ErrExit
    NumCols = CLng(InputBox("How Many Columns per Row?"))
    RwHght = CSng(InputBox("What row height for the pictures, in Centimeters (e.g. 4.5)?"))
    On Error GoTo 0
    'Select and insert the Pics
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select image files and click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        If .Show = -1 Then
            'Add a 3-row by NumCols-column table to take the images
            Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=3, NumColumns:=NumCols)
            With ActiveDocument.PageSetup
                TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
            End With
            With oTbl
                .Borders.Enable = True
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = TblWdth / NumCols
            End With
            CaptionLabels.Add Name:="Picture"
            For i = 1 To .SelectedItems.Count Step NumCols
                r = ((i - 1) / NumCols + 1) * 3 - 2
                'Format the rows
                Call FormatRows(oTbl, r, RwHght)
                For c = 1 To NumCols
                    j = j + 1
                    'Insert the Picture
                    ActiveDocument.InlineShapes.AddPicture _
                    FileName:=.SelectedItems(j), LinkToFile:=False, _
                    SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range
                    'Get the Image name for the Caption
                    StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
                    StrTxt = ": " & Split(StrTxt, ".")(0)
                    'Insert the Caption on the row below the picture
                    With oTbl.Cell(r + 1, c).Range
                        .InsertBefore vbCr
                        .Characters.First.InsertCaption _
                        Label:="Picture", Title:=StrTxt, _
                        Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                        .Characters.First = vbNullString
                        .Characters.Last.Previous = vbNullString
                    End With
                    'Exit when we're done
                    If j = .SelectedItems.Count Then Exit For
                Next
                'Add extra rows as needed
                If j < .SelectedItems.Count Then
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                End If
            Next
        Else
        End If
    End With
ErrExit:
    Application.ScreenUpdating = True
End Sub
 '
Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
    With oTbl
        With .Rows(x)
            .Height = CentimetersToPoints(Hght)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Normal"
        End With
        With .Rows(x + 1)
            .Height = CentimetersToPoints(0.5)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Caption"
        End With
    End With
End Sub

---

With this macro you can specify however many picture columns you want and whatever row height you want. Whether you have the 'right' amount of white space depends on the settings you use. Quite obviously, if you specify the row height to be 6 cm and your pictures can't fill that at the correct aspect ratio, you're going to have some white space left over.

Apologies for the delay. Is it possible to adapt the macro code to have the image caption above the image as with the initial code? e.g. Desert and just Picture/figure 1 below the image?

Try:

Code:

---

Sub AddPics()
    Application.ScreenUpdating = False
    Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
    Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
    On Error GoTo ErrExit
    NumCols = CLng(InputBox("How Many Columns per Row?"))
    RwHght = CSng(InputBox("What row height for the pictures, in Centimeters (e.g. 4.5)?"))
    On Error GoTo 0
    'Select and insert the Pics
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select image files and click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        If .Show = -1 Then
            'Add a 3-row by NumCols-column table to take the images
            Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=3, NumColumns:=NumCols)
            With ActiveDocument.PageSetup
                TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
            End With
            With oTbl
                .Borders.Enable = True
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = TblWdth / NumCols
            End With
            CaptionLabels.Add Name:="Picture"
            For i = 1 To .SelectedItems.Count Step NumCols
                r = ((i - 1) / NumCols + 1) * 3 - 1
                'Format the rows
                Call FormatRows(oTbl, r, RwHght)
                For c = 1 To NumCols
                    j = j + 1
                    'Insert the Picture
                    ActiveDocument.InlineShapes.AddPicture _
                    FileName:=.SelectedItems(j), LinkToFile:=False, _
                    SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range
                    'Get the Image name for the Caption
                    StrTxt = Split(Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\"))))(0)
                    'Insert the Caption on the row below the picture
                    With oTbl.Cell(r - 1, c).Range
                        .Text = StrTxt
                    End With
                    With oTbl.Cell(r + 1, c).Range
                        .InsertBefore vbCr
                        .Characters.First.InsertCaption _
                          Label:="Picture", Title:="", _
                          Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                        .Characters.First = vbNullString
                        .Characters.Last.Previous = vbNullString
                    End With
                    'Exit when we're done
                    If j = .SelectedItems.Count Then Exit For
                Next
                'Add extra rows as needed
                If j < .SelectedItems.Count Then
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                End If
            Next
        Else
        End If
    End With
ErrExit:
    Application.ScreenUpdating = True
End Sub
 '
Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
    With oTbl
        With .Rows(x - 1)
            .Height = CentimetersToPoints(0.5)
            .HeightRule = wdRowHeightExactly
            With .Range
              .Style = "Normal"
              With .ParagraphFormat
                .SpaceBefore = 0
                .SpaceAfter = 0
              End With
            End With
        End With
        With .Rows(x)
            .Height = CentimetersToPoints(Hght)
            .HeightRule = wdRowHeightExactly
            With .Range
              .Style = "Normal"
              With .ParagraphFormat
                .SpaceBefore = 0
                .SpaceAfter = 0
              End With
            End With
        End With
        With .Rows(x + 1)
            .Height = CentimetersToPoints(0.5)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Caption"
        End With
    End With
End Sub

---

What would be the easiest way to change the text colour in the 3 row down using the Sub Format rows?

I've tried the code below, but can't seem to get it to work.

Code:

---

Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
    With oTbl
        With .Rows(x)
            .Height = CentimetersToPoints(Hght)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "No spacing"
            .Cells.VerticalAlignment = wdCellAlignVerticalCenter
        End With
    End With
        With .Rows(x + 1)
            .Height = CentimetersToPoints(0.5)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Caption"
            .Range.Font.Size = 8
        End With
        With .Rows(x + 2)
            .Height = CentimetersToPoints(0.5)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "No spacing"
            .Range.Font.Size = 12
            .Range.Font.ColorIndex = wdDarkRed
            End With
    End With
End Sub

---

Instead of messing with the code willy-nilly you should take time to understand what it is doing. You do that by stepping through the code. It is hardly surprising .Rows(x + 2) doesn't work - since that row doesn't exist!