View Single Post
 
Old 09-24-2018, 02:14 AM
gmayor's Avatar
gmayor gmayor is offline Windows 10 Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,137
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

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
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote