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

20174
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/showthread.php?44473-Insert-Multiple-Pictures-Into-Table-Word-With-Macro&p=306321&viewfull=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!