Consulting

Results 1 to 6 of 6

Thread: Macro to insert images into table

  1. #1
    VBAX Newbie
    Joined
    Mar 2020
    Posts
    3
    Location

    Post Macro to insert images into table

    I am trying to create a Macro for Word, where I can select multiple pictures and insert them into a table, 2 Columns wide, with pictures on the odd rows and their captions on the even rows. I want to resize each picture to 8cm wide, and have no borders on the table.


    I have attached images of the end result I am trying to achieve (minus the visible borders).

    Any help would be appreciated a lot, cheers.
    Below is the closest code I have found to what I want. The code is from the user macropod, on here.
    Table example with border.JPG

    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
        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
    Last edited by macropod; 03-30-2020 at 07:35 PM. Reason: Added code tags & formatting

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    After:
    With oTbl
    insert:
    .Borders.Enable = False


    You should also change:
    .Columns.Width = CentimetersToPoints(7)
    to:
    .Columns.Width = CentimetersToPoints(8)

    You might also find it useful to change:
    .Height = CentimetersToPoints(7)
    to something more closely approximating the required picture height. If they're only in landscape format with the typical 3:2 aspect ratio, you might use:
    .Height = CentimetersToPoints(5.33)
    For pics using a 4:3 ratio, you might use:
    .Height = CentimetersToPoints(6)
    But, if you have a mix of pics in portrait and landscape orientation, you'd probably want to use:
    .Height = CentimetersToPoints(8)
    Last edited by macropod; 03-30-2020 at 06:07 PM.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  3. #3
    VBAX Newbie
    Joined
    Mar 2020
    Posts
    3
    Location
    The table leaves large gaps after every image, how would I remove these?
    The images are a mix of landscape and portrait.
    Also the text is blue, what could i change to make it black?

    Below is an image of the result with the current code.
    Cheers for the help Paul.

    Table with problem.JPG

  4. #4
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Quote Originally Posted by neoncake View Post
    The table leaves large gaps after every image, how would I remove these?

    Did you read what I said in my previous reply about the image heights?
    Quote Originally Posted by neoncake View Post
    The images are a mix of landscape and portrait.

    The images in your post are only in landscape format. If you change the row heights to suit landscape images, your portrait images will be scaled down to suit that height.

    Another approach would be to insert:
    .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
    or:
    .Range.Cells.VerticalAlignment = wdCellAlignVerticalBottom
    after:
    With oTbl
    to change where the images sit within their cells.
    Quote Originally Posted by neoncake View Post
    Also the text is blue, what could i change to make it black?
    By changing the Caption Style.
    Last edited by macropod; 03-30-2020 at 07:42 PM.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  5. #5
    VBAX Newbie
    Joined
    Mar 2020
    Posts
    3
    Location
    Quote Originally Posted by macropod View Post

    Did you read what I said in my previous reply about the image heights?


    The images in your post are only in landscape format. If you change the row heights to suit landscape images, your portrait images will be scaled down to suit that height.

    Another approach would be to insert:
    .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
    or:
    .Range.Cells.VerticalAlignment = wdCellAlignVerticalBottom
    after:
    With oTbl
    to change where the images sit within their cells.
    By changing the Caption Style.
    Ahh i misread, thanks. I've got a few portrait photos so i'll try stick with 8cm for now.

    Thankyou for your help, I really appreciate it!

  6. #6
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

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