Consulting

Page 1 of 3 1 2 3 LastLast
Results 1 to 20 of 53

Thread: Insert Multiple Pictures Into Table Word With Macro

  1. #1
    VBAX Regular
    Joined
    Nov 2012
    Posts
    12
    Location

    Insert Multiple Pictures Into Table Word With Macro

    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.
    [vba]
    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
    [/vba]
    Attached Images Attached Images

  2. #2
    VBAX Wizard
    Joined
    May 2004
    Posts
    6,713
    Location
    What exactly aee you asking?

  3. #3
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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.
    Last edited by macropod; 12-04-2022 at 12:43 AM.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  4. #4
    VBAX Wizard
    Joined
    May 2004
    Posts
    6,713
    Location
    I'm sorry, but I just have to grin. Nice one Paul.

  5. #5
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    That's far better than a grimmace ....
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  6. #6
    VBAX Wizard
    Joined
    May 2004
    Posts
    6,713
    Location
    hee hee hee, there is that isn't there? Ah choices...

  7. #7
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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_p...ry_add_in.html
    Greg

    Visit my website: http://gregmaxey.com

  8. #8
    VBAX Wizard
    Joined
    May 2004
    Posts
    6,713
    Location
    Greg, would it be possible that I get to see the source code for that?

  9. #9
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Gerry, send website feedback and we'll discuss offline via e-mail (since your private message box is full).
    Greg

    Visit my website: http://gregmaxey.com

  10. #10
    VBAX Regular
    Joined
    Nov 2012
    Posts
    12
    Location
    @Paul Edstein
    Thanks, this is what I was looking for.

    Kind regards

    Mark

  11. #11

    modification to code

    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

    Quote Originally Posted by macropod View Post
    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.

  12. #12
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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?
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  13. #13
    Quote Originally Posted by macropod View Post
    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

  14. #14
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  15. #15
    VBAX Regular
    Joined
    Oct 2013
    Posts
    6
    Location
    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

  16. #16
    VBAX Newbie
    Joined
    Oct 2013
    Posts
    3
    Location
    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.


  17. #17
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Quote Originally Posted by princess View Post
    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?
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  18. #18
    VBAX Newbie
    Joined
    Oct 2013
    Posts
    3
    Location
    Quote Originally Posted by macropod View Post
    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

  19. #19
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  20. #20
    VBAX Newbie
    Joined
    Oct 2013
    Posts
    3
    Location
    Thank you so much, I really appreciate you taking the time to help me on this =)

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •