使用Excel VBA调整单词中图像的大小

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 中的图片插入具有固定高度和宽度的表格单元格中，可以限制插入到 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"样式，确保图片在其单元格中水平居中并正确填充可用空间。单元格也垂直居中。您可以更改这些参数中的任何一个。