Microsoft Office Forums

Go Back   Microsoft Office Forums > >

 
 
Thread Tools Display Modes
Prev Previous Post   Next Post Next
  #1  
Old 10-12-2024, 08:47 AM
mathemagician44 mathemagician44 is offline Photo and Caption insert macro adjustments Windows 11 Photo and Caption insert macro adjustments Office 2019
Novice
Photo and Caption insert macro adjustments
 
Join Date: Jan 2022
Posts: 7
mathemagician44 is on a distinguished road
Default Photo and Caption insert macro adjustments

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

Reply With Quote
 



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
Photo and Caption insert macro adjustments 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
Photo and Caption insert macro adjustments insert photo on top of movie wabash12 PowerPoint 2 06-14-2013 06:32 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 01:47 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2025, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2025 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft