Resizing image in word using Excel VBA

Question

I have this code in excel VBA that creates a word document and paste my screenshot. What I want to do next is to resize the image so i can fit more images in a single page, unfortunately I really don't know what to do next after I paste the image

Sub Testing()
    Dim wrd As Word.Application

    Set wrd = Word.Application

    With wrd
      .Visible = True
      .Activate
      .Documents.Add
      Call PrintScreen
      .Selection.Paste
      'What should i do next?
    end with

End Sub

If you don't want to use the approached proposed by "macropod" then we have to know whether the paste operation is inserting the image in-line with text (as an InlineShape) or with text wrapping (as a Shape). The simplest to code and work with would be inserting as an InlineShape, which can then be converted to a Shape explicitly after the paste operation. Can you give us that information? — Cindy Meister
I also tried to used the InlineShape method, but it seems that it doesn't see that image that I pasted as an InlineShape because the InlineShapes.Count always produce 0 value — John Louie Gonzales
What does ActiveDocument.Shapes.Count return? If you execute the following: .PictureWrapType = wdWrapMergeInline and then Paste, do you then get an InlineShapes.Count? — Cindy Meister

macropod macropod · Accepted Answer · 2018-05-10T23:12:20

You can constrain the size of pictures inserted into Word by inserting them into table cells having a fixed height and width.

The following macro allows the user to select multiple images for insertion into a table with as many columns as they choose and picture row heights of their choice. Table column widths are determined by the page print width. Captions are added below each picture.

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 max height for the pictures, in centimeters (e.g. 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
    'Create a paragraph Style with 0 space before/after & centre-aligned
    On Error Resume Next
    With ActiveDocument
      .Styles.Add Name:="TblPic", Type:=wdStyleTypeParagraph
      On Error GoTo 0
      With .Styles("TblPic").ParagraphFormat
        .Alignment = wdAlignParagraphCenter
        .SpaceAfter = 0
        .SpaceBefore = 0
      End With
    End With
    '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 = CentimetersToPoints(Hght)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
  With .Rows(x + 1)
    .Height = CentimetersToPoints(0.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
  End With
End With
End Sub

As coded, the macro uses the "Caption" Style for the caption rows. This left-aligns the captions. It also uses a custom "TblPic" Style for the image rows, ensuring the pictures are horizontally centred in their cells and correctly fill the space available. Cells are also centred vertically. You can change any of these parameters.

Resizing image in word using Excel VBA

1 Answers