Insert Multiple Pictures Into Table Word With Macro

[Novio]

Hello,
I would like to use a macro to insert several pictures in a table. In the first row the picture and in the second row the text "Pictures x"
look like attachment.
A have a bit of code.

Sub Test()
'
' Test Macro
'
'
Dim fd As FileDialog
Dim oTbl As Table
Dim oILS As InlineShape
Dim vrtSelectedItem As Variant
'Add a 1 row 2 column table to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 2)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
End With
With oTbl.Rows.First
.Height = CentimetersToPoints(7)
.HeightRule = wdRowHeightExactly
End With
With oTbl.Columns.First
.Width = CentimetersToPoints(7)
End With
With oTbl.Columns.Last
.Width = CentimetersToPoints(7)
End With
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

[fumei]

What exactly aee you asking?

[macropod]

I believe the OP wants to be able to select multiple pictures and insert them into a table, with pictures on the odd rows and their captions on the even rows. To that end, try:

Sub AddPics()
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
'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
'Add a 2-row by 2-column table with 7cm columns to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 2)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(7)
'Format the rows
Call FormatRows(oTbl, 1)
End With
CaptionLabels.Add Name:="Picture"
For i = 1 To .SelectedItems.Count
j = Int((i + 1) / 2) * 2 - 1
k = (i - 1) Mod 2 + 1
'Add extra rows as needed
If j > oTbl.Rows.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If
'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(k).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the row below the picture
With oTbl.Rows(j + 1).Cells(k).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x)
.Height = CentimetersToPoints(7)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
End With
End SubAs coded, the paragraph Style for the image rows is set to 'Normal'. I suggest creating another paragraph Style, with 0 space before and after, plus the 'Keep with next' attribute, and using that instead of the 'Normal' Style.

[fumei]

I'm sorry, but I just have to grin. Nice one Paul.

[macropod]

That's far better than a grimmace ....

[fumei]

hee hee hee, there is that isn't there? Ah choices...

[gmaxey]

I don't know if you will grin or grimmace, but I published an add-in for doing something similar a could have months ago:

http://gregmaxey.mvps.org/word_tip_pages/photo_gallery_add_in.html

[fumei]

Greg, would it be possible that I get to see the source code for that?

[gmaxey]

Gerry, send website feedback and we'll discuss offline via e-mail (since your private message box is full).

[Novio]

@Paul Edstein
Thanks, this is what I was looking for.

Kind regards

Mark

[gsinclair]

Paul,

Have seen this very useful bit of code and was wondering if you could assist in modifying it for a particular end purpose?

Essentially as written, but with a single column, so that there are only 2 images per page. Can you assist?

Thanks
George


I believe the OP wants to be able to select multiple pictures and insert them into a table, with pictures on the odd rows and their captions on the even rows. To that end, try:

Sub AddPics()
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
'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
'Add a 2-row by 2-column table with 7cm columns to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 2)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(7)
'Format the rows
Call FormatRows(oTbl, 1)
End With
CaptionLabels.Add Name:="Picture"
For i = 1 To .SelectedItems.Count
j = Int((i + 1) / 2) * 2 - 1
k = (i - 1) Mod 2 + 1
'Add extra rows as needed
If j > oTbl.Rows.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If
'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(k).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the row below the picture
With oTbl.Rows(j + 1).Cells(k).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x)
.Height = CentimetersToPoints(7)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
End With
End Sub
As coded, the paragraph Style for the image rows is set to 'Normal'. I suggest creating another paragraph Style, with 0 space before and after, plus the 'Keep with next' attribute, and using that instead of the 'Normal' Style.

[macropod]

Hi George,

I've been OS for 3½ months, hence the delay in replying. Have you resolved the issue, or do you still need help?

[gsinclair]

Hi George,

I've been OS for 3½ months, hence the delay in replying. Have you resolved the issue, or do you still need help?


No solution as yet Paul, so would really appreciate any help!

cheers
George

[macropod]

Try the following. Only a few minor changes were needed:

Sub AddPics()
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, StrTxt As String
'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
'Add a 2-row by 1-column table with 7cm column width to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 1)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(7)
'Format the rows
Call FormatRows(oTbl, 1)
End With
CaptionLabels.Add Name:="Picture"
For i = 1 To .SelectedItems.Count
j = i * 2 - 1
'Add extra rows as needed
If j > oTbl.Rows.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If
'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(1).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the row below the picture
With oTbl.Rows(j + 1).Cells(1).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x)
.Height = CentimetersToPoints(7)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
End With
End Sub

[Mark90]

I don't know if you will grin or grimmace, but I published an add-in for doing something similar a could have months ago:

This is great Greg, I could see me using very soon. Thanks for posting. Now reading everything on your site :D

[princess]

Can someone please help me with putting the caption on the row above the photo and ommitting adding "Picture '#':" to the caption? And the caption shows up blue, is there a way to ensure the text is black?

I am trying to use the macro that macropod had posted on this thread.

[macropod]

Can someone please help me with putting the caption on the row above the photo and ommitting adding "Picture '#':" to the caption? And the caption shows up blue, is there a way to ensure the text is black?

I am trying to use the macro that macropod had posted on this thread.
I have posted two macros in this thread, one for a two-column table, the other for a one-column table. To which of them do you refer?

[princess]

I have posted two macros in this thread, one for a two-column table, the other for a one-column table. To which of them do you refer?

Sorry, the two column table.

Thank you

[macropod]

Try:

Sub AddPics()
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
'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
'Add a 2-row by 2-column table with 7cm columns to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 2)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(7)
'Format the rows
Call FormatRows(oTbl, 1)
End With
For i = 1 To .SelectedItems.Count
j = Int((i + 1) / 2) * 2 - 1
k = (i - 1) Mod 2 + 1
'Add extra rows as needed
If j > oTbl.Rows.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If
'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(j + 1).Cells(k).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
'Insert the Caption on the row above the picture
oTbl.Rows(j).Cells(k).Range.Text = Split(StrTxt, ".")(0)
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x + 1)
.Height = CentimetersToPoints(7)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x)
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
End With
End Sub

[princess]

Thank you so much, I really appreciate you taking the time to help me on this =)

[palaceofrev]

Would there happen to be a way to do this with two photos per page with a caption under each photo?

[macropod]

There are various ways. For example:
1. Make the cell size for the pictures large enough that only one row of pictures plus their captions would fit on a page;
2. Instead of adding new rows for each pair of pictures, insert a page break and add a new table.
The easiest is item 1.

[Frozsh]

..

[macropod]

Without wanting to place too fine a point on it, you're trying to run a Word macro in Excel.

[macropod]

Would there happen to be a way to do this with two photos per page with a caption under each photo?
Cross-posted at: http://www.excelforum.com/word-programming-vba-macros/975113-need-help-inserting-multiple-pictures-at-once-with-macro.html
For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184

[palaceofrev]

Sorry for cross-posting, still really new to the help forum.

I've acquired a code that seems to do the trick for the most part but i need the caption to read "Picture #1:" ect...
Also, this code doesn't seem to place my pictures in order.

Sub InsertMultipleImagesFixed()
Dim fd As FileDialog
Dim oTable As Table
Dim iRow As Integer
Dim iCol As Integer
Dim oCell As Range
Dim i As Long
Dim sNoDoc As String
Dim picName As String
Dim scaleFactor As Long
Dim max_height As Single
'define resize constraints
max_height = 275

'add a 1 row 2 column table to take the images
Set oTable = Selection.Tables.Add(Selection.Range, 1, 1)
'+++++++++++++++++++++++++++++++++++++++++++++
'oTable.AutoFitBehavior (wdAutoFitFixed)
oTable.Rows.Height = CentimetersToPoints(4)
oTable.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
'++++++++++++++++++++++++++++++++++++++++++++++

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png; *.wmf"
.FilterIndex = 2
If .Show = -1 Then

For i = 1 To .SelectedItems.Count

iCol = 1
iRow = i
'get filename
picName = Right(.SelectedItems(i), Len(.SelectedItems(i)) - InStrRev(.SelectedItems(i), "\"))
'remove extension from filename ****
picName = Left(picName, InStrRev(picName, ".") - 1)

'select cell
Set oCell = oTable.Cell(iRow, iCol).Range

'insert image
oCell.InlineShapes.AddPicture FileName:= _
.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oCell

'resize image
If oCell.InlineShapes(1).Height > max_height Then
scale_factor = oCell.InlineShapes(1).ScaleHeight * (max_height / oCell.InlineShapes(1).Height)
oCell.InlineShapes(1).ScaleHeight = scale_factor
oCell.InlineShapes(1).ScaleWidth = scale_factor
End If

'center content
oCell.ParagraphFormat.Alignment = wdAlignParagraphCenter

'insert caption below image
oCell.InlineShapes(1).Range.InsertCaption Label:="Figure", TitleAutoText:="", _
Title:=": " & picName, Position:=wdCaptionPositionBelow, ExcludeLabel:=True

If i < .SelectedItems.Count And i Mod 2 = 0 Then 'add another row, more to go
oTable.Rows.Add
End If
Next i
End If
End With

Set fd = Nothing
End Sub



Please, anything you can offer would be really helpful.

[macropod]

I've already pretty much told you how to do this for yourself - read the code I posted, especially the 'FormatRows' sub. As it is, I don't even know what page size, margin sizes etc you're working with.

[uhayatpk]

Hello every one,

I want to change in this code from 2 columns to 3 columns, I highlighted the problem area where the problem arise. Urgent need this solution. Please help me.

Sub InsertImages()
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
'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
'Add a 2-row by 2-column table with 7cm columns to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 3)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(6)
'Format the rows
Call FormatRows(oTbl, 1)
End With
CaptionLabels.Add Name:="Picture"
For i = 1 To .SelectedItems.count

'-------Problem Area

j = Int((i + 1) / 2) * 2 - 1
k = (i - 1) Mod 2 + 1


'Add extra rows as needed
If j > oTbl.Rows.count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If
'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(k).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the row below the picture
With oTbl.Rows(j + 1).Cells(k).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x)
.Height = CentimetersToPoints(5.5)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(0.7)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
End With
End Sub

[macropod]

Hello uhayatpk,

Please note that you should not leave issues until they're urgent. It may not be convenient for anyone who can answer your post to respond at that time. Secondly, when posting code, please use the code tags. They're on the 'Go Advanced' tab.

I've modified the code from the previous posts so you can now 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.

As coded, the macro uses the "Normal" and "Caption" Styles. These both left-align the content, but you can change that and which Styles get used.

Sub AddPics()
Application.ScreenUpdating = False
Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
RwHght = CSng(InputBox("What row height for the pictures, in inches (e.g. 1.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
'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 ActiveDocument.PageSetup
TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = TblWdth / NumCols
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
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(j), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range
'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 = InchesToPoints(Hght)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(0.5)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
End With
End Sub

[uhayatpk]

Thanks Paul Edstein - You are Genius.

[uhayatpk]

I have another question regarding this topic. Are we use three parallel table. Table has one column & one Row. e.g. Insert one table and after specified position insert second table and after this insert third table.

Once again thanks for your co-operation.

[macropod]

Since the macro inserts the table wherever you have the insertion point, simply move that to wherever you want each table inserted. Pretty obvious, I would have thought.

[bilareal]

Hello,

Isn't possible in a 2 columns model insert the photo only in the left cell of the line, and let free the right cell to make a description text?
And insert the caption and photo in the same cell (caption above the photo)?

[macropod]

Hello,

Isn't possible in a 2 columns model insert the photo only in the left cell of the line, and let free the right cell to make a description text?
And insert the caption and photo in the same cell (caption above the photo)?
Not with that macro. A completely different one would be required for that.

[bilareal]

Not with that macro. A completely different one would be required for that.


I tried this, but i can't get fix the error in the caption!


Sub InsertMultipleImagesWithFilename()
Dim fd As FileDialog
Dim oTable As Table
Dim iRow As Integer
Dim iCol As Integer
Dim oCell As Range
Dim i As Long
Dim sNoDoc As String
Dim picName As String
Dim scaleFactor As Long
Dim max_height As Single
'define resize constraints
max_height = 275

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)
oTable.Rows.Height = CentimetersToPoints(4)
oTable.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
'++++++++++++++++++++++++++++++++++++++++++++++

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
For i = 1 To .SelectedItems.Count
'find col,row #s
If i Mod 2 = 0 Then 'even number right column
iRow = i / 2
iCol = 2
Else 'odd number left column new row
iRow = (i + 1) / 2
iCol = 1
End If
iRow = i
iCol = 1

'get filename
picName = Right(.SelectedItems(i), Len(.SelectedItems(i)) - InStrRev(.SelectedItems(i), "\"))
'remove extension from filename ****
picName = Left(picName, InStrRev(picName, ".") - 1)

'select cell
Set oCell = oTable.Cell(iRow, iCol).Range

'insert image
oCell.InlineShapes.AddPicture FileName:= _
.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oCell

'resize image
If oCell.InlineShapes(1).Height > max_height Then
scale_factor = oCell.InlineShapes(1).ScaleHeight * (max_height / oCell.InlineShapes(1).Height)
oCell.InlineShapes(1).ScaleHeight = scale_factor
oCell.InlineShapes(1).ScaleWidth = scale_factor
End If

'center content
oCell.ParagraphFormat.Alignment = wdAlignParagraphLeft

'insert caption above image
oCell.InlineShapes(1).Range.InsertCaption Label:="imagem", TitleAutoText:="", _
Title:=":" & picName, Position:=wdCaptionPositionAbove, ExcludeLabel:=True





If i < .SelectedItems.Count And i Mod 2 = 0 Then 'add another row, more to go
oTable.Rows.Add
End If

If i < .SelectedItems.Count Then 'add another row, more to go
oTable.Rows.Add
End If

Next i
End If
End With

Set fd = Nothing
End Sub

[bilareal]

Can help me?

[macropod]

Try:

Sub AddPics()
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
'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
'Add a 'Picture' caption label
CaptionLabels.Add Name:="Picture"
'Add a 2-row by 2-column table with 7cm columns to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 1, 2)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(7)
End With
For i = 1 To .SelectedItems.Count
'Add extra rows as needed
With oTbl
If i > .Rows.Count Then oTbl.Rows.Add
With .Rows(i)
.Height = CentimetersToPoints(7)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
.Cells(1).Range.Text = vbCr
.Cells(1).Range.Characters.Last.Style = "Caption"
End With
End With
'Insert the Picture
ActiveDocument.InlineShapes.AddPicture FileName:=.SelectedItems(i), _
LinkToFile:=False, SaveWithDocument:=True, _
Range:=oTbl.Cell(i, 1).Range.Characters.First
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the line below the picture
With oTbl.Cell(i, 1).Range
.Characters.Last.Previous.InsertCaption Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.Last.Previous = vbNullString
End With
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub
PS: When posting code, please use the code tags. They're indicated by the # button on the posting screen.

[bilareal]

Run-time error '5834':

.Cells(1).Range.Characters.Last.Style = "Caption"


Any idea?

[macropod]

Works for me - otherwise I wouldn't have posted it.

[bilareal]

Thank you very much! Works great! Solved my problem!
To work in my model i only changed in the line the reference "Caption" to "Normal".

[Intz]

First of all i would like to say Im a native spanish speaker and probably my written english wont be the best and more than one mistake will take place.

I tried Greg addins but doesnt work something in the code maybe, the gallery closes.

I tried the code above given by Paul, but makes mi word close. Maybe is the size of the picture Im not sure.

I liked the idea of image inside a table but im not sure if is my best way to format the report. I used to have an engenier that makes me the macros (Im a Geographer) and I only took a basic course of macros for excel, so word is winning me this time.

Here is what I need.
I got almost 100 images(screen print), need to paste 2 per page (so it will need resize to 42%) and above the image the file name. Inline to the paragraph,
Until there it would be great.

But if you are a magician of vba, the hole product will have some string under (next line): like this maybe

image file name
Image
Sentido Ida: Sentido Retorno:
1era Estación Ida: 1era Estación Retorno:

Paul can you help me??

or any one please!!
Thanks in advance looking foward to hear replies

Rocio

[macropod]

I have posted multiple macros in this thread, all of which work correctly. Other people have posted macros too, or links to them. Since I don't know which of my macros you're using, I can't possibly comment on why one of them might not work for you, especially given that you haven't mentioned anything about error messages and the like. As for Greg's macro, you'd need to discuss that with him.

[Intz]

Hi Paul...

I read you kind of mad... if so I sorry... I didnt name the problem because it apears in spanish I dont know how to translate it.
About your macros posted aboved I work with it trying to solve the problem. And Actually I did fix it.
But still is not MY BEST way because I dont want the images in a Table, as I posted above.
Also I tried to modified and insert more lines in the table for the extra strings I need. And it only works if I choose 1 image... if I select more it does what it should as you programm it.

as I told before this real hard for me, but Im not quitting.


Sub AddPics() Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, StrTxt As String
'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
'Add a 4-row by 1-column table with 15cm column width to take the images
Set oTbl = Selection.Tables.add(Selection.Range, 4, 1)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(15)
'Format the rows
Call FormatRows(oTbl, 1)
End With
CaptionLabels.add Name:="Figura"
For i = 1 To .SelectedItems.Count
j = i * 2 - 1
'Add extra rows as needed
If j > oTbl.Rows.Count Then
oTbl.Rows.add
oTbl.Rows.add
Call FormatRows(oTbl, j)
End If
'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(1).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the row below the picture
With oTbl.Rows(j + 1).Cells(1).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Figura", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x)
.Height = CentimetersToPoints(10)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
End With
End Sub


Also I took your code and others found in other websites how to insert images, trying to solve my problem and do it without a table and keep the part of telling the name of the image and the number.... but I havent make it work yet. Probably because i dont know the commands well. and how to name what I want.

Just came my boss to speak to me and told yeld it me because I havent got this this thing working yet... actually is frustraing to demand things from people there are not capable of... (sorry I know this paragrahs is not accurate to the theme) but im need to share it some how, because he left me crying.

Paul... I really hope you can helpme

[macropod]

The code I have provided in this thread is only for inserting images and below them their captions into a table. If you want to do something different, you will need different code, or to add some manual procedures as well.

For example, to insert the captions above the pictures you need to -

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

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

change:
With .Rows(x)
to:
With .Rows(x + 1)

change:
With .Rows(x + 1)
to:
With .Rows(x)

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

[izno99]

Try:

Sub AddPics()
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
'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
'Add a 2-row by 2-column table with 7cm columns to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 2)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(7)
'Format the rows
Call FormatRows(oTbl, 1)
End With
For i = 1 To .SelectedItems.Count
j = Int((i + 1) / 2) * 2 - 1
k = (i - 1) Mod 2 + 1
'Add extra rows as needed
If j > oTbl.Rows.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If
'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(j + 1).Cells(k).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
'Insert the Caption on the row above the picture
oTbl.Rows(j).Cells(k).Range.Text = Split(StrTxt, ".")(0)
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x + 1)
.Height = CentimetersToPoints(7)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x)
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
End With
End Sub

Hello,

Thanks for that Code, I would like to use that macro to build a chart with 2 column, 3 row with a with of 9 cm per page.
The picture and the text in the chart must be center and the size of the image must have a height of 6cm and a with of 8cm

Can someone help me with that macro.

[macropod]

I would like to use that macro to build a chart with 2 column, 3 row with a with of 9 cm per page.
The picture and the text in the chart must be center and the size of the image must have a height of 6cm and a with of 8cm
Be my guest. A careful reading of the code will show what changes need to be made for the height and width. As for the number of rows, that is controlled by how many pictures you select.

[debug.assert]

Hello, I want to say thank you very much for this code Paul it works very well. I would like to make one change for my purposes but can't seem to find in the code where to turn off the automatic incremental numbering "Picture 1" "Picture 2" etc.

When I try

ExcludeLabel:=True

I get "1" "2"

maybe I need a different type of caption?

Thanks in advance

[nando88]

I am trying to modify your code, so that I can add multiple images, but with the option that the user can specify the number of rows and columns that will appear in a single page.
I am using your code, with a bit of modifications in the image size:


Sub AddPics()
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
'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
'Add a 2-row by 2-column table with 7cm columns to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 4, 4)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(4)
'Format the rows
Call FormatRows(oTbl, 1)
End With
CaptionLabels.Add Name:="Figura"
For i = 1 To .SelectedItems.Count
j = Int((i + 1) / 2) * 2 - 1
k = (i - 1) Mod 2 + 1
'Add extra rows as needed
If j > oTbl.Rows.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If
'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(k).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the row below the picture
With oTbl.Rows(j + 1).Cells(k).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Figura", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x)
.Height = CentimetersToPoints(5)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(1.3)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
End With
End Sub



n someone please help me?

[lalli]

Nice!

[sharens1]

I came across this website, and reviewed and applied this code - It is awesome. I need to make some tweaks to this, and I was wondering if anyone would help me.. I am a N00B when it comes to macros, and all I have done is goofed this up alot. Could anybody help me out?

In addition, I would like to:

centers pictures in table
Inserts figure reference (Figure 1, etc. numerically)
Would like a maximum of four images, which would take a majority of the page. The images would be likely 40%-50% current size.

Any help or guidance would be much appreciated. heres the code:


Sub AddPics()
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String

'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
'Add a 2-row by 2-column table with 7cm columns to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 2)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(7)
'Format the rows
Call FormatRows(oTbl, 1)
End With

For i = 1 To .SelectedItems.Count
j = Int((i + 1) / 2) * 2 - 1
k = (i - 1) Mod 2 + 1
'Add extra rows as needed

If j > oTbl.Rows.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If

'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(j + 1).Cells(k).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
'Insert the Caption on the row above the picture
oTbl.Rows(j).Cells(k).Range.Text = Split(StrTxt, ".")(0)
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub


Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x + 1)
.Height = CentimetersToPoints(7)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x)
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
End With
End Sub

[gmaxey]

Have you tried using the add-in:

http://gregmaxey.com/word_tip_pages/photo_gallery_add_in.html

[sharens1]

Greg,

Many thanks. I am looking for something that is MACRO based, rathr than via add-on. Could you help me?

[SamT]

Sharens, please start a new thread completely describing the issue, Post any code you already have, and as soon as you have 5 posts, please attach the Doc.

I am locking this 5 yo thread now.