Help to adjust photo caption macro

NicB · #1 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

gmayor · #2 09-24-2018, 02:14 AM

The following changes to your first macro will address both your concerns. You may also be interested in http://www.gmayor.com/photo_gallery_template.html .

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
'
'Graham Mayor - http://www.gmayor.com - Last updated - 24 Sep 2018

Dim oTbl As Table, i As Long, j As Long, StrTxt As String
Dim fd As Object
Dim bHyphen As Boolean
Dim strTitle As String

    Application.ScreenUpdating = False
    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
            If MsgBox("Include hyphen at end of caption?", vbYesNo) = vbYes Then bHyphen = True
            If bHyphen = True Then
                strTitle = " - "
            Else
                strTitle = ""
            End If
            '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:=strTitle, _
                            Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                    .Characters.First = vbNullString
                    If Not bHyphen = True Then
                        .Characters.Last.Previous = vbNullString
                    Else
                        .Characters.Last.Previous = Chr(32)
                    End If
                End With
                DoEvents
            Next
        Else
        End If
    End With
    Application.ScreenUpdating = True
End Sub

NicB · #3 09-24-2018, 11:02 AM

This is perfect - thank you very much Graham. I would never have figure the update out!

I do have the photo galley add-in on my personal laptop - it is a brilliant little app. Unfortunately, I'm unable to use it for work

Thank you again.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Loop macro to adjust text formating within Word	beardsa	Word VBA	1	02-01-2018 12:10 AM
How do I adjust above spacing in table?	Silverlining	Word	1	07-02-2016 10:10 AM
Word 2010 Run-Time error 4198 with Insert Picture with Caption and Fram Macro	jstills116	Word VBA	0	06-24-2016 07:46 AM
adjust lines to single	rolypoly71	Word	1	08-17-2015 10:09 AM
Adjust speed of ppt animation	gerryb	PowerPoint	0	08-15-2009 08:45 AM