Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Closed Thread
 
Thread Tools Display Modes
  #1  
Old 08-22-2022, 04:29 PM
macropod's Avatar
macropod macropod is offline Automate the insertion of multiple images into a document, all scaled to the same size Windows 10 Automate the insertion of multiple images into a document, all scaled to the same size Office 2016
Administrator
Automate the insertion of multiple images into a document, all scaled to the same size
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,713
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default Automate the insertion of multiple images into a document, all scaled to the same size

The simplest way to insert images into a document and constrain their dimensions to a given size is to insert them into table that has the 'automatically resize to fit contents' option 'off' and with the cell width and 'exact' height set to the maximum allowable for each image (eg, in a 2*2 table, the column width would be, say, half the intra-margin width and the row height would be half the intra-margin height). You can turn off the table's border display. With this setup, any image you insert into the table will be constrained so that it fits into the cell whilst maintaining the correct aspect ratio.

The following macro automates the insertion of multiple images into a table (which the macro also creates) in a Word document. As coded, it allows you to specify any number of columns and the picture row height. The column-width is calculated automatically, based on the page print width. Any inserted pictures will be constrained to fit the available cell space, at the correct aspect ratio, by enlarging/reducing them, as appropriate. Below each image is a row for adding a caption. The process begins at wherever the selection/insertion point is.

As coded, the macro uses the "Caption" Style for the caption rows. This left-aligns the captions. It also uses a custom "TblPic" Style for the image rows, ensuring the pictures are horizontally centred in their cells and correctly fill the space available. Cells are also centred vertically. You can change any of these parameters.
Code:
Sub AddPicsWithCaption()
'Sourced from: https://www.msofficeforums.com/drawing-and-graphics/49547-automate-insertion-multiple-images-into-document-all.html
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
With ActiveDocument.PageSetup
  TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
ColWdth = PointsToCentimeters(TblWdth / NumCols)
ColWdth = CentimetersToPoints(CSng(InputBox("What max width for the pictures, in Centimeters (e.g. " & Format(ColWdth, "0.00") & ")?")))
RwHght = CentimetersToPoints(CSng(InputBox("What max height for the pictures, in Centimeters (e.g. 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 oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = True
    End With
    CaptionLabels.Add Name:="Picture"
    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 = ": " & Split(StrTxt, ".")(0)
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c).Range
          .InsertBefore vbCr
          .Characters.First.InsertCaption _
          Label:="Picture", Title:=StrTxt, _
          Position:=wdCaptionPositionBelow, ExcludeLabel:=False
          .Characters.First = vbNullString
          .Characters.Last.Previous = vbNullString
        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
  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 = CentimetersToPoints(0.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
  End With
End With
End Sub
• If you want a predetermined number of columns without the need to respond to a prompt, change:
NumCols = CLng(InputBox("How Many Columns per Row?"))


to:
NumCols = 4
where '4' is the number of columns.

• If you want a predetermined column width without the need to respond to a prompt, change:
ColWdth = PointsToCentimeters(TblWdth / NumCols)
ColWdth = CentimetersToPoints(CSng(InputBox("What max width for the pictures, in Centimeters (e.g. " & Format(ColWdth, "0.00") & ")?")))
to:
ColWdth = CentimetersToPoints(4)
where '4' is the width, in centimeters.

• If you want a predetermined row height without the need to respond to a prompt, change:
RwHght = CentimetersToPoints(CSng(InputBox("What max height for the pictures, in Centimeters (e.g. 5)?")))
to:
RwHght = CentimetersToPoints(5)
where '5' is the row height in cm.

• If you want to use a fixed column-width, you could change:
.Columns.Width = TblWdth / NumCols
to, say:
.Columns.Width = CentimetersToPoints(7.5)
where '7.5' is the required width in cm (try not to use a column width & count that exceed your printable area!).

• If you're concerned to prevent overly-long captions wrapping, you can:
1. Reduce the Caption Style's font size; and/or
2. Apply the 'Fit Text' option to long captions so they fit on one line. This might be accomplished by inserting:
Code:
          If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
            .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
            .FitTextWidth = ColWdth
          End If
after:
Code:
          .Characters.Last.Previous = vbNullString
• To insert the captions above the pictures you need to -
1. Change:
.KeepWithNext = True
to:
.KeepWithNext = False
and insert:
.Styles("Caption").ParagraphFormat.KeepWithNext = True
after:
CaptionLabels.Add Name:="Picture"

2. Change:
SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range
to:
SaveWithDocument:=True, Range:=oTbl.Cell(r + 1, c).Range

3. Change:
With oTbl.Cell(r + 1, c).Range
to:
With oTbl.Cell(r, c).Range

4. Swap:
With .Rows(x)
and:
With .Rows(x + 1)

• If your situation is one in which the images may change from time to time, but you want to avoid replacing them manually each time, you could change:
LinkToFile:=False
to:
LinkToFile:=True
That way, the images will auto-update if you replace them with others of the same name.

• For a borderless table, change:
.Borders.Enable = True
to:
.Borders.Enable = False

• If you don't want the final result to be in a table, insert:
oTbl.ConvertToText
before:
Else

• If you prefer to work in imperial units rather than metric units, change all
Centimeters
references to:
Inches

To insert Pics without Captions:
Code:
Sub AddPicsNoCaption()
'Sourced from: https://www.msofficeforums.com/drawing-and-graphics/49547-automate-insertion-multiple-images-into-document-all.html
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 = CLng(InputBox("How Many Columns per Row?"))
RwHght = CentimetersToPoints(CSng(InputBox("What max height for the pictures, in Centimeters (e.g. 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 1-row by NumCols-column table to take the images
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=1, NumColumns:=NumCols)
    With ActiveDocument.PageSetup
      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
      .Rows.Height = RwHght
      .Rows.HeightRule = wdRowHeightExactly
      .Range.Style = "TblPic"
      .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
      .Borders.Enable = True
    End With
    For i = 1 To .SelectedItems.Count Step NumCols
      r = ((i - 1) / NumCols + 1) * 2 - 1
      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
        If j = .SelectedItems.Count Then Exit For
      Next
      'Add extra rows as needed
      If j < .SelectedItems.Count Then
        oTbl.Rows.Add
      End If
    Next
  Else
  End If
End With
ErrExit:
Application.ScreenUpdating = True
End Sub
For PC macro installation & usage instructions, see: Installing Macros
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Closed Thread

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Automate the insertion of multiple images into a document, all scaled to the same size Looking for Help with Resizing Multiple Images in a Document CrossReach Word VBA 3 12-02-2018 07:53 PM
Automate the insertion of multiple images into a document, all scaled to the same size Insert multiple images into Word document from smartphone james1979uk Drawing and Graphics 1 06-06-2018 01:12 AM
ms word 2013 massively increases file size of images inserted into new word document rbg Drawing and Graphics 0 06-05-2016 08:04 AM
Automate the insertion of multiple images into a document, all scaled to the same size Scaled Down Forms billgyrotech Word 2 03-25-2016 02:17 PM
Automate the insertion of multiple images into a document, all scaled to the same size Insert multiple images & controls into a document vanwijnen Word VBA 1 06-05-2015 06:16 AM

Other Forums: Access Forums

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


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