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:


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


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:

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

[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. 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 MyStringAnd 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:

'add a 1 row 2 column table to take the images
Set oTable = Selection.Tables.Add(Selection.Range, 1, 2)
oTable.AutoFitBehavior (wdAutoFitFixed)
Replace the last of the lines above with:
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

[Novio]

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

[macropod]

It would have been helpful if you specified all of your requirements up front. I'm really not interested in being fed a problem in piecemeal fashion. I imagine the other contributors here have much the same attitude. Indeed, instead of hijacking an existing thread, you should start a new thread. Please do so - with the full specifications of your requirements, including whatever code you are now using and details of what aspects you're having trouble with.

[Novio]

Sorry,

[MacroStarter]

Hi Talis,

Upon inserting multiple images with captions, I would like to automatically resize the images to make them fit into the page (1 image per page) with caption underneath. Could you shed some lights on how to do this? many thanks!!

Bing


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.

[styff17]

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


First of all NB here so if I am not using the proper format, please forgive me!

I love this macro and will use it many times I am sure, but was wondering if you might be so kind as to help me to tweak it just slightly.

When I ran this macro the caption reads as follows: "Picture 1(imageName)", As an example, my first image reads: "Picture 1001". I would like to remove the "Picture 1" part and replace that with "#". I have figured out how to remove the word picture but not the sequential numbers. My filenames are the numbers in a 001, 002, etc format so it is redundant to have Picture 1 and so on there.

Also how can I pull other info from the image file such as date taken, image size, etc?

Lastly, Is there a place for us beginners to learn some of these procedures and syntax. I believe I saw a link somewhere in this thread but can't remember where!

Thank you in advance!

[macropod]

For what you described, you could use something like:
oILS.Range.InsertAfter Chr(11) & "# " & Split(vrtSelectedItem, "\")(UBound(Split(vrtSelectedItem, "\")))
However, by not using Word's captioning system, it will be more work to cross-reference the pics later on.

As for getting the date taken, image size, etc., that would require considerably more work.

[styff17]

thank you!

[styff17]

ok so could I add a space between the sequential numbers so that it separates it from the file name or even better code that would kick it down a line?

[macropod]

Please make up your mind what you want. I don't enjoy wasting time developing solutions only to be told something different is wanted. Please also understand that Word's captioning requires the 'Picture' designation for cross-referencing, too.