resize multiple images and add captions to fit into page

[MacroStarter]

Hi! Upon inserting batch images with captions, some captions flow to the next page due to the size of the images. Is there a way to automatically resize the images so that together with the caption they will fit into the page (1 image per page with caption underneath)? many thanks!!

Here is the code that I used:

Sub InsertMultipleImages1on1()
Dim fd As FileDialog
Dim oTbl As Table
Dim oILS As InlineShape
Dim vrtSelectedItem As Variant
If Documents.Count = 0 Then
If MsgBox("No document open!" & vbCr & vbCr & _
"Do you wish to create a new document to hold the images?", _
vbYesNo, "Insert Images") = vbYes Then
Documents.Add
ActiveDocument.PageSetup.Orientation = wdOrientLandscape
Else
Exit Sub
End If
End If
'Add a 1 row 2 column table to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 1, 1)
oTbl.AutoFitBehavior (wdAutoFitFixed)
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
CaptionLabels.Add Name:="Caption test"
For Each vrtSelectedItem In .SelectedItems
With Selection
Set oILS = .InlineShapes.AddPicture(FileName:= _
vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _
Range:=Selection.Range)
oILS.Range.InsertCaption Label:="Caption test", TitleAutoText:="", Title:="", _
Position:=wdCaptionPositionBelow, ExcludeLabel:=0
.MoveRight wdCell, 1
End With
Next vrtSelectedItem
Else
End If
End With
If Len(oTbl.Rows.Last.Cells(1).Range) = 2 Then oTbl.Rows.Last.Delete
Set fd = Nothing
End Sub

[gmaxey]

Try this:


Sub InsertMultipleImages1on1()
Dim fd As FileDialog
Dim oTbl As Table
Dim oILS As InlineShape
Dim vrtSelectedItem As Variant
Dim oCap As CaptionLabel
If Documents.Count = 0 Then
If MsgBox("No document open!" & vbCr & vbCr & _
"Do you wish to create a new document to hold the images?", _
vbYesNo, "Insert Images") = vbYes Then
Documents.Add
ActiveDocument.PageSetup.Orientation = wdOrientLandscape
Else
Exit Sub
End If
End If
'Add a 1 row 1 column table to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 1, 1)
oTbl.AutoFitBehavior (wdAutoFitFixed)
oTbl.Rows.AllowBreakAcrossPages = False
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
CaptionLabels.Add Name:="Caption test"
For Each vrtSelectedItem In .SelectedItems
With Selection
Set oILS = .InlineShapes.AddPicture(FileName:= _
vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, Range:=Selection.Range)
oILS.Range.InsertCaption Label:="Caption test", TitleAutoText:="", Title:="", _
Position:=wdCaptionPositionBelow, ExcludeLabel:=0
With oILS
If .Height = ActiveDocument.PageSetup.PageHeight - (ActiveDocument.PageSetup.TopMargin + ActiveDocument.PageSetup.BottomMargin) Then
.LockAspectRatio = msoTrue
.Height = oILS.Height - 12
End If
End With
'Create new row.
.MoveRight wdCell, 1
End With
Next vrtSelectedItem
End If
End With
If Len(oTbl.Rows.Last.Cells(1).Range) = 2 Then oTbl.Rows.Last.Delete
Set fd = Nothing
End Sub

[MacroStarter]

Thank you so much, Greg! This works perfectly!! : )