Home > General > Word 2010 macro insert multiple images with captions

Word 2010 macro insert multiple images with captions

February 16th, 2012 Leave a comment Go to comments

Fiddling with trying to automate a report with multiple pictures created some headache but the nerd on me solved it and now i just press a button and I’m done.

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

            'get filename
            picName = Right(.SelectedItems(1), Len(.SelectedItems(1)) - InStrRev(.SelectedItems(1), "\"))
            '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
Tags:
  1. Gavin
    April 25th, 2012 at 08:33 | #1

    Hi,

    Thanks for submitting the code, it has been very useful, however could you please advise how I can amend the code so rather than having 2 columns i.e. a photo side by side, I can have 2 photo’s per page i.e. 1 column and 2 rows.

    I tried to amend it and got it part way there but then got an error code.

  2. Gavin
    April 25th, 2012 at 09:06 | #2

    Hi,

    I managed to teach myself and made the following changes:

    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 = 500

    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 table to take the images
    Set oTable = Selection.Tables.Add(Selection.Range, 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"
    .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 / 1
    Else 'odd number left column new row
    iRow = (i + 1)
    iCol = 1
    End If

    'get filename
    picName = Right(.SelectedItems(1), Len(.SelectedItems(1)) - InStrRev(.SelectedItems(1), "\"))
    '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 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

  3. RN
    June 27th, 2012 at 12:38 | #3

    This is a great macro. Thanks for posting it! I was wondering what I would alter to keep the auto-numbering but to remove the photo file names from the captions. Any help would be much appreciated! Thank you!

  4. Jon
    September 12th, 2012 at 12:00 | #4

    Great Macro and it is very close to what I am trying to do. I am try to do something similar to what Gavin is doing above. I would like to just insert multiple images with captions but without using a table. I have been trying to modified the code but I have had no success.

    Giving into the idea of using a table I thought about adding some extra variables or even a dialog box so the user can specify the size of the table.

    Also, using your code or Gavin’s, when I use the macro all the different images have the same file name.

    Any thought on any of this? especially the trouble I am having with the file name.

    Thanks for your time and help.

  5. Coder
    October 28th, 2012 at 23:26 | #5

    Thanks for the code! There were a few probs:
    - needed an ‘i’ to iterate to the next file name to avoid printing the same name over and over!
    - got rid of some unnecessary error checking.
    - Made it work for 1 column.

    Have fun!

    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

  6. LOUISA
    November 10th, 2012 at 08:02 | #6

    Hi there

    I am not familiar with setting up macros but this seems like exactly what I need. Can you explain how and where to enter this macro? Would save me 3/4 hours today!

  7. Clabauter
    November 13th, 2012 at 04:16 | #7

    this is a great script,
    but i am trying to get 2 additional lines of text below the picture, and i have no idea how to manage this ..
    can anybody help me with this?

    Thanks for your professional help

    Clabauter

  8. Jacquie
    May 8th, 2013 at 14:51 | #8

    @Gavin

    Okay, real dummy here. I would like to use the macro to insert/properly size photos into a Word table with 2 photos per page, but do not know how to copy and past into Word to get it to work. I tried clicking Record Macro and pasting it into the description, but it did not work. Please help!

  9. December 12th, 2013 at 12:25 | #9

    Word 2013 changed a few things on how macros work and are inserted. An updated code is below, and here is the tutorial of how to insert the macro.

    1)Save as macro enabled file (.docm)
    2)File>Options>Customize Ribbon>Ensure Developer is selected and click ok
    ensure you have the area where you want to insert the images selected now
    3)Developer>Visual Basic
    4)in the VB window insert>procedure (name,sub,public) and click ok
    5)paste the following code in the sub area

    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; *.wmf;"
    '.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

    '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

    6)press the play button in the VB window

  10. William
    February 17th, 2014 at 15:55 | #10

    What needs to be changed in the code to remove the caption auto numbering. I would like the option of only printing the file name as the caption.

  1. No trackbacks yet.