使用Excel VBA在Word中調整圖像大小

Question

我在excel VBA中有此代碼，該代碼可創建word文檔並粘貼我的屏幕截圖。 我下一步要做的是調整圖像大小，以便可以在一個頁面中容納更多圖像，但是不幸的是，粘貼圖像后我真的不知道下一步該怎么做。

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

Answer 1

您可以通過將圖片插入到具有固定高度和寬度的表格單元格中來限制插入Word的圖片的大小。

下面的宏允許用戶選擇要插入表中的多個圖像，這些圖像具有選擇的列數和選擇的圖片行高。 表格列的寬度由頁面打印寬度決定。 在每張圖片下方添加了字幕。

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”樣式，以確保圖片在其單元格中水平居中並正確填充可用空間。 單元也垂直居中。 您可以更改任何這些參數。