Microsoft Office Forums - View Single Post - [Solved] Help to adjust photo caption macro

NicB · 09-24-2018, 12:47 AM

I've used the following macro for a couple of years, which adds a single column table with space for two photos and captions underneath. It has served me very well and saved me a huge amount of time with inserting up to 300+ images into documents. This was not code I wrote - i just tweaked it to include the caption i needed and the image size I wanted.

There has been one niggle that i could never get to the bottom of - how do get a space to appear after the -? A simple thing, but for the life of me I couldn't get anything i tried to work. I literally spent hours on it and gave up in the end.

Also, it would be brilliant if i had the option to exclude the dash entirely, as there are times when I just need the label. I know I could duplicate this macro and remove the dash, but that's probably a bit overkill. Worst case, I can record a macro to find all instances of the dash and delete them (although if i'm half asleep, it could have a detrimental effect on the remainder of the document!).

I have nil understanding of VBA and wouldn't know where to begin, or if indeed it is possible. Would anyone be able to assist, please?

Code:

Sub AddCaptionedImages()
'
' Inserts a 1 column x 4 row/page table into a page, with an image in the first row and a caption in the second row
'
'

    Application.ScreenUpdating = False
    Dim oTbl As Table, i As Long, j As Long, StrTxt As String
    Dim fd As Object
    Set fd = Application.FileDialog(3)
     'Select and insert the Pics
    With fd
        .Title = "Select image files and click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        If .Show = -1 Then
             'Add a 2-row by 1-column table with 7cm column width to take the images
            Set oTbl = Selection.Tables.Add(Selection.Range, 2, 1)
            With oTbl
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = CentimetersToPoints(15.98)
                 'Format the rows
                Call FormatRows(oTbl, 1)
            End With
            CaptionLabels.Add Name:="Photograph"
            For i = 1 To .SelectedItems.Count
                j = i * 2 - 1
                 'Add extra rows as needed
                If j > oTbl.Rows.Count Then
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                    Call FormatRows(oTbl, j)
                End If
                 'Insert the Picture
                ActiveDocument.InlineShapes.AddPicture _
                FileName:=.SelectedItems(i), LinkToFile:=False, _
                SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(1).Range
                 'Get the Image name for the Caption
                StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
                StrTxt = ": " & Split(StrTxt, ".")(0)
                 'Insert the Caption on the row below the picture
                With oTbl.Rows(j + 1).Cells(1).Range
                    .InsertBefore vbCr
                    .Characters.First.InsertCaption _
                    Label:="Photograph", Title:=" - ", _
                    Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                    .Characters.First = vbNullString
                    .Characters.Last.Previous = vbNullString
                End With
            Next
        Else
        End If
    End With
    Application.ScreenUpdating = True
End Sub
 '
Sub FormatRows(oTbl As Table, x As Long)
    With oTbl
        With .Rows(x)
            .Height = CentimetersToPoints(10)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Normal"
            .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        End With
        With .Rows(x + 1)
            .Height = CentimetersToPoints(1.7)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Caption"
            .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        End With
    End With
End Sub