Sub setpicsize() '批量缩放Word图片

    Dim mmpx    'mm 转换成 像素的 参数

    mmpx = 2.835

    Dim n '图片个数

    Dim picwidth    '图片宽度

    Dim picheight   '图片高度

    Dim pagewidth

    Dim pageheight

    Dim TopMargin

    Dim BottomMargin

    Dim LeftMargin

    Dim RightMargin

    Dim usefulwidth

    Dim usefulheight

    pagewidth = ActiveDocument.PageSetup.pagewidth

    pageheight = ActiveDocument.PageSetup.pageheight

    TopMargin = ActiveDocument.PageSetup.TopMargin

    BottomMargin = ActiveDocument.PageSetup.BottomMargin

    LeftMargin = ActiveDocument.PageSetup.LeftMargin

    RightMargin = ActiveDocument.PageSetup.RightMargin

    usefulwidth = pagewidth - LeftMargin - RightMargin

    usefulheight = pageheight - TopMargin - BottomMargin

    Dim s

    'MsgBox TopMargin, vbOKOnly

    'Exit Sub

    On Error Resume Next '忽略错误

    For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片

        picheight = ActiveDocument.InlineShapes(n).Height   '获取图片高度（像素值）

        picwidth = ActiveDocument.InlineShapes(n).Width     '获取图片宽度（像素值）

        

        '设置宽度适合文档大小

        '（420/picwidth）为缩放比例

        '其中，420为Word中A4纸默认工作宽度（估计值。。。）

        If usefulheight / picheight >= usefulwidth / picwidth Then

          s = usefulwidth / picwidth

        Else

          s = usefulheight / picheight

        End If

        ActiveDocument.InlineShapes(n).Width = picwidth * s   '缩放宽度

        ActiveDocument.InlineShapes(n).Height = picheight * s '同比例缩放高度

        

    Next n

    

    For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片

        picheight = ActiveDocument.Shapes(n).Height

        picwidth = ActiveDocument.Shapes(n).Width

        

        ActiveDocument.Shapes(n).Width = picwidth * s   '同上

        ActiveDocument.Shapes(n).Height = picheight * s '同上

        

    Next n

End Sub

'

'Word中的尺寸单位默认是cm（厘米），而1cm等于28.35px（像素），由于代码中换算设置的单位是px（像素）。所以就用尺寸高度或宽度值乘像素值。即为：7*28.35=198.45；宽度换算方法与此相同。

'