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

[dan_tunnicli]

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

image.jpg
Any help would be appreciated.

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.

[gmayor]

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

[dan_tunnicli]

Ideally after something macro based rather than an add-on

[macropod]

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

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.

[dan_tunnicli]

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?

[macropod]

Try:

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

[dan_tunnicli]

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.

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

[macropod]

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!