Insert Multiple Pictures Into Table Word With Macro

[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-progr...ith-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".