Photo and Caption insert macro adjustments

mathemagician44 · #1 10-12-2024, 08:47 AM

Good Morning,

I have cobbled together the following macro from this site over the years that I use to post many photos in multiple reports each week. Word recently lost my macro so I went to my previous posts to recover much of what I had. The macro allows me to number the photos to make their order, then inserts the caption using only the filename after the initial number.

I've had a guy on Upwork make me a different code for this photo insert macro that works, but only on the templates that he designed for me. So I'd like to go back to my original macro I made from here.

I have always had to select the 30 to 50 photos/captions and adjust the tabs to center the photos/captions on the pages. Is there an easier way that I can do this? The photos are 3.5" high by 4.67" wide, perhaps the macro can automatically put everything between tabs at 7/8" and 5-9/16"

Less important, because I make multiple report styles, is there a way that I can tell the macro to BOLD only the words Photograph and the field number also?

Thank you so much for your time.

Code:

Sub AddPics()
Application.ScreenUpdating = False
Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long, iShp As InlineShape
Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single, ColWdth As Single
On Error GoTo ErrExit
NumCols = 1
RwHght = InchesToPoints(3.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
    'Create a paragraph Style with 0 space before/after & centre-aligned
    On Error Resume Next
    With ActiveDocument
      .Styles.Add Name:="TblPic", Type:=wdStyleTypeParagraph
      On Error GoTo 0
      With .Styles("TblPic").ParagraphFormat
        .Alignment = wdAlignParagraphCenter
        .KeepWithNext = True
        .SpaceAfter = 0
        .SpaceBefore = 0
      End With
    End With
    'Add a 2-row by NumCols-column table to take the images
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
    With ActiveDocument.PageSetup
            .LeftMargin = (InchesToPoints(1))
            .RightMargin = (InchesToPoints(1))
            TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      ColWdth = TblWdth / NumCols
    End With
    With oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = False
    End With
   
    CaptionLabels.Add Name:="Photograph"
    For i = 1 To .SelectedItems.Count Step NumCols
      r = ((i - 1) / NumCols + 1) * 2 - 1
      'Format the rows
      Call FormatRows(oTbl, r, RwHght)
      For c = 1 To NumCols
        j = j + 1
        'Insert the Picture
        Set iShp = ActiveDocument.InlineShapes.AddPicture( _
          FileName:=.SelectedItems(j), LinkToFile:=False, _
          SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
          
        With iShp
          .LockAspectRatio = True
          If (.Width < ColWdth) And (.Height < RwHght) Then
            .Width = ColWdth
            If .Height > RwHght Then .Height = RwHght
          End If
        End With
        'Get the Image name for the Caption
        StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
        
        StrTxt = Left(StrTxt, InStrRev(StrTxt, ".") - 1)
        StrTxt = " - " & Right(StrTxt, Len(StrTxt) - Len(Split(StrTxt, " ")(0)) - 1)
        
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c).Range
        .InsertBefore vbCr
        .Characters.First.InsertCaption _
        Label:="Photograph", Title:=StrTxt, _
        Position:=wdCaptionPositionBelow, ExcludeLabel:=False
        .Characters.First = vbNullString
        .Characters.Last.Previous = vbNullString
        .Font.Size = 12
        .Font.Name = Calibri
        .Font.Italic = False
        .Font.ColorIndex = wdBlack
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
                
        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
      End If
    Next
    oTbl.ConvertToText
  Else
  End If
End With
ErrExit:
Application.ScreenUpdating = True

  
  With Selection.Find
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindAsk
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
  End With
  Selection.Find.Execute Replace:=wdReplaceAll

End Sub

Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
With oTbl
  With .Rows(x)
    .Height = Hght
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
  
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
  With .Rows(x + 1)
    .Height = InchesToPoints(1)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
  End With
End With
End Sub

macropod · #2 10-12-2024, 03:43 PM

Since you say the photos are 3.5" high by 4.67" wide, simply delete the TblWdth line and change

Code:

TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
ColWdth = TblWdth / NumCols

to

Code:

ColWdth = InchesToPoints(4.67)

You can also delete:

Code:

        With iShp
          .LockAspectRatio = True
          If (.Width < ColWdth) And (.Height < RwHght) Then
            .Width = ColWdth
            If .Height > RwHght Then .Height = RwHght
          End If
        End With

Then to center the table on the page and have no borders, simply add:

Code:

    oTbl.Borders.Enable = False
    oTbl.Rows.Alignment = wdAlignRowCenter

after:

Code:

Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)

You can then also delete:

Code:

oTbl.ConvertToText

since you'll now have a centered, borderless, table.

As for:

Code:

        .Font.Size = 12
        .Font.Name = Calibri
        .Font.Italic = False
        .Font.ColorIndex = wdBlack
        .ParagraphFormat.Alignment = wdAlignParagraphCenter

None of that is necessary. What you should be doing is changing the Caption Style to give it the desired characteristics. Then all you need instead of that code is:

Code:

          .Words(1).Font.Bold = True
          .Words(2).Font.Bold = True

to Bold 'Photograph' and the Caption #.

I have no idea why you've added:

Code:

  With Selection.Find
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindAsk
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
  End With
  Selection.Find.Execute Replace:=wdReplaceAll

to the code, since it doesn't do anything meaningful.

mathemagician44 · #3 10-13-2024, 08:58 AM

I cannot thank you enough Macropod. This is great!

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Insert photo reference inside callout	brownees	Word VBA	1	05-12-2024 04:36 PM
Modifying Macropod's Macro (Insert Multiple Images with Caption)	stevenjohnson	Drawing and Graphics	4	02-07-2024 09:07 AM
Help to adjust photo caption macro	NicB	Word VBA	2	09-24-2018 11:02 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
insert photo on top of movie	wabash12	PowerPoint	2	06-14-2013 06:32 AM