1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
</pre><pre name="code" class="vb">Sub 插入图片()
Dim myfile As FileDialog
Set myfile = Application.FileDialog(msoFileDialogFilePicker)
With myfile
.InitialFileName = "D:"
If .Show = -1 Then
For Each fn In .SelectedItems
Set mypic = Selection.InlineShapes.AddPicture(FileName:=fn, SaveWithDocument:=True)
mypic.Width = 28.345 * 6.3 '根据需要设置
mypic.Height = 28.345 * 5.4
Next fn
End If
End With
Set myfile = Nothing
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Public Sub ResizeThePicture()
On Error Resume Next
Dim picW As Single, picH As Single
Dim cellW As Single, cellH As Single
Dim rtoW As Single, rtoH As Single
cellW = ActiveCell.Width
cellH = ActiveCell.Height
picW = Selection.ShapeRange.Width
picH = Selection.ShapeRange.Height
rtoW = cellW / picW * 0.95
rtoH = cellH / picH * 0.95
If rtoW < rtoH Then
Selection.ShapeRange.ScaleWidth rtoW, msoFalse, msoScaleFromTopLeft
Else
Selection.ShapeRange.ScaleHeight rtoH, msoFalse, msoScaleFromTopLeft
End If
picW = Selection.ShapeRange.Width
picH = Selection.ShapeRange.Height
Selection.ShapeRange.IncrementLeft (cellW - picW) / 2
Selection.ShapeRange.IncrementTop (cellH - picH) / 2
End Sub

1
2
3
4
5
6
7
8
9
10
11
Sub 图片大小处理()
Dim iSha As InlineShape
For Each iSha In ActiveDocument.InlineShapes
If iSha.Type = wdInlineShapePicture Then
iSha.LockAspectRatio = msoFalse
iSha.Width = CentimetersToPoints(4.6)
iSha.Height = CentimetersToPoints(4.2)
End If
Next
End Sub

1
2
3
4
5
6
7
8
Sub 图片处理一()
Mywidth = 5.21 '5.21为图片宽度（厘米）
Myheigth = 3.92 '3.92为图片高度（厘米）
For Each iShape In ActiveDocument.InlineShapes
iShape.Height = 28.345 * Myheigth '1cm等于28.35px
iShape.Width = 28.345 * Mywidth '1cm等于28.35px
Next iShape
End Sub

1
2
3
4
5
6
7
8
9
Sub 图片大小处理二()
' 批量设置图片尺寸
' 设置好第一张整改图片（假设整改图片位于整个文档图片第k位）的大小之后,运行此宏即可.
Dim n
For n = k + 1 To ActiveDocument.InlineShapes.Count '注：k+1表示第二张整改图片，实际操作中要填入实际数值
ActiveDocument.InlineShapes(n).Width = ActiveDocument.InlineShapes(k).Width 'k表示第一张整改图片，实际操作中要填入实际数值
ActiveDocument.InlineShapes(n).Height = ActiveDocument.InlineShapes(k).Height 'k表示第一张整改图片，实际操作中要填入实际数值
Next n
End Sub