2020-06-24word自动调整图片大小

2012-03-14

用这个宏吧，我也是找了2113好久好久，不是我5261写的，感谢那个原4102创者。如下：1653

Sub 图片统一大小()

On Error Resume Next

Dim mywidth

Dim myheight

Application.ScreenUpdating = False '关闭屏幕更新

mywidth = Val(InputBox(Prompt:="单位为厘米(cm);如果输入为0，则图片保持原始纵横比,宽度根据输入的高度数值自动调整；", Title:="请输入图片宽度", Default:="0")) * 28.35

myheight = Val(InputBox(Prompt:="单位为厘米(cm);如果输入为0，则图片保持原始纵横比,高度根据输入的宽度数值自动调整；", Title:="请输入图片高度", Default:="0")) * 28.35

'------------------------------------------------------------------

'调整嵌入式图形

Dim pic As InlineShape

For Each pic In ActiveDocument.InlineShapes

If mywidth = "0" Then

pic.Height = myheight

pic.ScaleWidth = pic.ScaleHeight

ElseIf myheight = "0" Then

pic.Width = mywidth

pic.ScaleHeight = pic.ScaleWidth

Else

pic.Width = mywidth

pic.Height = myheight

End If

Next

'调整浮动式图形

Dim tu As Shape

For Each tu In ActiveDocument.Shapes

If mywidth = "0" Then

tu.Height = myheight

ElseIf myheight = "0" Then

tu.Width = mywidth

Else

tu.LockAspectRatio = msoFalse

tu.Width = mywidth

tu.Height = myheight

End If

Next

Application.ScreenUpdating = True '恢复屏幕更新

End Sub