Microsoft Office Forums - View Single Post

arcticpinecone · 02-12-2024, 08:47 AM

I've gotten this closer to what I'd like it to be but still have a few remaining questions. Please help!

How do I...

1) Automatically resize the photos and set a maximum allowable size for height/width? I have photos that are in landscape and portrait and this code unfortunately cuts off the portrait photos (height > width) to the specified row height.
2) save onto the network & share as a template with other users at my organization? Does the macro code need to be created/save to the "Normal.dotm"
3) alter the paragraph/line spacing or other formatting for the caption text? FIGURED IT OUT!! This is so simple and elegant! The code specifies that the caption text will be the same as caption style in Word. So all you have to do is go to that style and modify anything you want (font type, size, line spacing, etc)
4) remove the autonumbering after the caption word "photo"? FIGURED IT OUT!! I had found another post that referenced this but couldn't get it to work. Then I realized I just needed to add "photo" into the code above the line I had modified (both in bold).

Code:

'Get the Image name for the Caption
        StrTxt = Split(.SelectedItems(j), "")(UBound(Split(.SelectedItems(j), "")))
        StrTxt = "Photo: " & Split(StrTxt, ".")(0)
        'Insert the Caption on the row below the picture
        oTbl.Cell(r + 1, c).Range.Text = StrTxt
        'Exit when we're done

Here's code I've modified

Code:

Sub AddPicsWithCaptionJS()
'Sourced from: https://www.msofficeforums.com/drawi...-document.html
Application.ScreenUpdating = False
Dim Stl As Style, 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
With ActiveDocument.PageSetup
  TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
On Error GoTo ErrExit
NumCols = 1
ColWdth = InchesToPoints(5.5)
RwHght = InchesToPoints(4)
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 & left-aligned
    With ActiveDocument
      On Error Resume Next
      Set Stl = .Styles("TblPic")
     If Stl Is Nothing Then Set Stl = .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 oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = False
    End With
    CaptionLabels.Add Name:="Photo"
    For i = 1 To .SelectedItems.Count Step NumCols
      r = oTbl.Rows.Count - 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 = "Photo: " & Split(StrTxt, ".")(0)
        'Insert the Caption on the row below the picture
        oTbl.Cell(r + 1, c).Range.Text = StrTxt
        '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
  Else
  End If
End With
ErrExit:
Application.ScreenUpdating = True
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(0.4)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
  End With
End With
End Sub