使用Excel VBA在Word中调整图像大小 [英] Resizing image in word using Excel VBA

问题描述

我在excel VBA中具有此代码，该代码可创建word文档并粘贴我的屏幕截图.我下一步要做的是调整图像大小，以便可以在单个页面中容纳更多图像，但是不幸的是，粘贴图像后我真的不知道下一步该怎么做

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

推荐答案

通过将插入到Word中的图片插入具有固定高度和宽度的表格单元中，可以限制图片的大小.

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

按照编码，宏将标题行使用标题"样式.这使字幕左对齐.它还对图像行使用自定义的"TblPic"样式，以确保图片在其单元格中水平居中并正确填充可用空间.单元也垂直居中.您可以更改任何这些参数.

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.

这篇关于使用Excel VBA在Word中调整图像大小的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！