Consulting

Results 1 to 6 of 6

Thread: Macro to insert images into table

Threaded View

Previous Post Previous Post   Next Post Next Post
  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

Posting Permissions

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