Modify Macro which Batch Insert Photos to also include caption

[ncasper]

I found the following macro on the internet which opens a file dialog and allows you to insert multiple photo files into a Word table. The macro works great but I would like to add a caption to each photo.

Here is the Macro:

Sub InsertMultipleImages()
Dim fd As FileDialog
Dim oTable As Table
Dim sNoDoc As String
Dim vrtSelectedItem As Variant
If Documents.Count = 0 Then
sNoDoc = MsgBox(" " & _
"No document open!" & vbCr & vbCr & _
"Do you wish to create a new document to hold the images?", _
vbYesNo, "Insert Images")
If sNoDoc = vbYes Then
Documents.Add
Else
Exit Sub
End If
End If
'add a 1 row 2 column table to take the images
Set oTable = Selection.Tables.Add(Selection.Range, 1, 2)
oTable.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
oTable.Cell(1, 1).Select
For Each vrtSelectedItem In .SelectedItems
With Selection
.InlineShapes.AddPicture FileName:= _
vrtSelectedItem _
, LinkToFile:=False, SaveWithDocument:=True, _
Range:=Selection.Range
.MoveRight Unit:=wdCell
End With
Next vrtSelectedItem
Else
End If
End With
If Len(oTable.Rows.Last.Cells(1).Range) = 2 Then
oTable.Rows.Last.Delete
End If
Set fd = Nothing
End Sub

I would like it to add "Photo 1", Photo 2", etc beneath each photo. If this can't be done I would settle for the filename but that would be my second choice.

Any idea how to modify this or where I could go to figure it out? I have very limitted knowledge of VBA.

[gmaxey]

Try:

Sub InsertMultipleImages()
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
  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, 2)
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:="Picture"
    For Each vrtSelectedItem In .SelectedItems
      With Selection
        Set oILS = .InlineShapes.AddPicture(FileName:= _
           vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _
           Range:=Selection.Range)
        oILS.Range.InsertCaption Label:="Picture", 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

[ncasper]

Thank you....that works perfect.

[darabontc]

Very helpful...
I need to do 1 adjustment to this: instead of showing me 6 pics/A4page, I need 4.
Thanks.

[darabontc]

4 pics, on landscape.
Thanks

[Talis]

Change the line:

Set oTbl = Selection.Tables.Add(Selection.Range, 1, 2)

to:

Set oTbl = Selection.Tables.Add(Selection.Range, 1, 4)

After the line:

Documents.Add

add:

ActiveDocument.PageSetup.Orientation = wdOrientLandscape

If you want to set the margins as well then you could record a macro, trim it and add these lines instead of the above line.

BTW this is a nice macro. Thanks for pointing it out and thanks to Greg.

[Paul_Hossler]

BTW this is a nice macro. Thanks for pointing it out and thanks to Greg.

Ditto - there's always something to learn here

Paul

[nobuffer]

I used the above macro with the changes to get 4 photos per page with captions. However, the 4 photos end up in 1 row on the page - I was looking to do 4 total photos per page with 2 on each row.

Any ideas?

[WebStone]

Hello Guys,

The code above works. This is my problem right now. I want to open figures or images the specified path (e.g. C:\Figures\In) with the specified code above but not in table format. This is my code right now:


[vba]Sub MergeFigures()
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim strFPath As String
Dim GetFullFile As String
If Documents.Count = 0 Then
If MsgBox("No document open!" & vbCr & vbCr & _
"Do you wish to create a new document to hold the figures?", _
vbYesNo, "Merge Figures") = vbYes Then
Documents.Add
Else
Exit Sub
End If
End If
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png; *.tiff"
.FilterIndex = 2
If .Show = -1 Then
CaptionLabels.Add Name:="Picture"
For Each vrtSelectedItem In .SelectedItems
With Selection
Set oILS = .InlineShapes.AddPicture(FileName:= _
vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _
Range:=Selection.Range)
oILS.Range.InsertCaption Label:="Figure", TitleAutoText:="", Title:="", _
Position:=wdCaptionPositionAbove, ExcludeLabel:=0
End With
Next vrtSelectedItem
Else
End If
End With
Set fd = Nothing[/vba]


But something happening in the output. It's not properly rendering the correct order, 3.bmp, 2.bmp, 1.bmp; the proper odering is 1.bmp, 2.bmp, 3.bmp. I want also to save the compile figures or images in the specified path (C:\Figures\Out). Anyone can help me? I'm stack on it and dunno much about VBA. This is for my college project. Thanks in advance.

[gmaxey]

Try:

[VBA]Sub MergeFigures()
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim strFPath As String
Dim GetFullFile As String
Dim oRng As Word.Range
Dim oILS As InlineShape
If Documents.Count = 0 Then
If MsgBox("No document open!" & vbCr & vbCr & _
"Do you wish to create a new document to hold the figures?", _
vbYesNo, "Merge Figures") = vbYes Then
Documents.Add
Else
Exit Sub
End If
End If
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png; *.tiff"
.FilterIndex = 2
Set oRng = Selection.Range
If .Show = -1 Then
CaptionLabels.Add Name:="Picture"
For Each vrtSelectedItem In .SelectedItems
Set oILS = oRng.InlineShapes.AddPicture(FileName:= _
vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _
Range:=oRng)
oILS.Range.InsertCaption Label:="Picture", TitleAutoText:="", Title:="", _
Position:=wdCaptionPositionAbove, ExcludeLabel:=0
Set oRng = oILS.Range
With oRng
.Collapse wdCollapseEnd
.MoveEnd wdCharacter, 1
.InsertBefore vbCr
End With
Next vrtSelectedItem
Else

End If
End With
Set fd = Nothing
End Sub
[/VBA]

[WebStone]

Thanks Greg but still have some sorting problem of the above code you have provided. The last picture comes first then the first one and so on...

[fumei]

Have you tried testing? If you replace the inserted pic with just a messagebox, try various selected files.[vba] If .Show = -1 Then
CaptionLabels.Add Name:="Picture"
For Each vrtSelectedItem In .SelectedItems
MyString = MyString & vrtSelectedItem & vbCrLf
' With Selection
' Set oILS = .InlineShapes.AddPicture(FileName:= _
' vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _
' Range:=Selection.Range)
' oILS.Range.InsertCaption Label:="Figure", TitleAutoText:="", Title:="", _
' Position:=wdCaptionPositionAbove
'
Next vrtSelectedItem
Else
End If
End With
Set fd = Nothing
MsgBox MyString[/vba]And yes, it puts the last first, and then the first one. But even then...sometimes it doesn't. It is not reliable, say 95% consistent, but over time I have found discrepancies.

It you want absolute certainty, perhaps dump vrtSelectedItem into an array, and THEN pull the image filename from the array. At least you could control things more.

[WebStone]

Thanks guyz!

I already figured out.

One thing, is there any way to embed .eps and ppt format?

[melodii]

Hi, just wondering what if I DO want the captions to be file names? (not picture 1, picture 2 etc), which part of the codes need to be modified to achieve this? (sorry I have no VBA knowledge)

Thanks!!

[macropod]

For the fullname (ie including the path) you could use:
oILS.Range.InsertCaption Label:="Picture", TitleAutoText:="", Title:=vrtSelectedItem, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=0

For the filename without the path you could use:
oILS.Range.InsertCaption Label:="Picture", TitleAutoText:="", _
Title:=Split(vrtSelectedItem, "\")(UBound(Split(vrtSelectedItem, "\"))), _
Position:=wdCaptionPositionBelow, ExcludeLabel:=0

[Novio]

Hello,
I have a question. Is it possible to give the columns a solid size.

Kind regards

Mark

[fumei]

I have no idea what you mean by "solid size", but it is clearly not related to the original question. You will likely get an answer if you post your (clarified) question to its own thread.

[Novio]

I want the pictures have a maximum high or wide from 6 cm, this can be done by give the columns and rows a fixed size. is that possible and how?

Kind regards

Mark

[macropod]

In the OP's original code, you'll find the lines:
[VBA]
'add a 1 row 2 column table to take the images
Set oTable = Selection.Tables.Add(Selection.Range, 1, 2)
oTable.AutoFitBehavior (wdAutoFitFixed)[/VBA]
Replace the last of the lines above with:
[vba]With oTable
.AutoFitBehavior (wdAutoFitFixed)
.AllowAutoFit = False
.TopPadding = CentimetersToPoints(0)
.BottomPadding = CentimetersToPoints(0)
.LeftPadding = CentimetersToPoints(0)
.RightPadding = CentimetersToPoints(0)
.Spacing = 0
.Rows.HeightRule = wdRowHeightExactly
.Rows.Height = CentimetersToPoints(6)
.Columns.Width = CentimetersToPoints(6)
End With[/vba]

[Novio]

Thanks.
Now I have another question. Is it possible to put the "Picture x" in the second row below the picture?