VBA操作WORD（五）批量調整圖片大小、居中設置

需求：經常閱讀網上的研報（沒錢買排版漂亮的高質量研報），有些需要保存的復制下來到word里，圖片很大都超出word的邊界了，也沒有居中，手工一張張調整不現實，上百頁的研報，幾十張圖片。

解決方案：利用VBA宏批量解決。

第一種方法經過測試，只是前面部分有些，后面部分無效。

 

Sub setpicsize() '設置圖片尺寸

'第一種方法，經測試，文檔前面部分圖片有效，后面部分無效
    'Dim n '圖片個數
    'On Error Resume Next '忽略錯誤
    'For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes 類型 圖片
    'ActiveDocument.InlineShapes(n).Height = 198.45 '設置圖片高度為 7cm
    'ActiveDocument.InlineShapes(n).Width = 455 '單位是像素，設置圖片寬度 16cm
    'Next n
End Sub

 

 第二種方法，經測試，對整篇文檔圖片有效：

Sub 設置圖片格式()
    '1.如果圖片行間距設置為固定值，那么無論圖片設置什么格式，圖片嵌入文字會重疊，只顯示部分圖片。
    '2.如果圖片超出邊界才進行處理，設置全文圖片大小不超過某個規格，超過則等比例縮小
    Dim picMaxWidth, picMaxHeight, picWith, picHeight As Long
    '紙張寬減去左右邊距，不用再乘以28.35，已經是像素
    picMaxWidth = (ActiveDocument.PageSetup.PageWidth - ActiveDocument.PageSetup.LeftMargin - ActiveDocument.PageSetup.RightMargin)
    picMaxHeight = (ActiveDocument.PageSetup.PageHeight - ActiveDocument.PageSetup.TopMargin - ActiveDocument.PageSetup.BottomMargin)
    Dim oILS As InlineShape
    For Each oILS In ActiveDocument.InlineShapes 'Selection.InlineShapes
        If oILS.Type = wdInlineShapePicture Then
        oILS.Select
            oILS.LockAspectRatio = msoTrue '鎖定縱橫比，防止默認沒有鎖定修改了圖片變形；不鎖定縱橫比是msoFalse
            Selection.Range.ShapeRange.LockAspectRatio = msoTrue
            'MsgBox("圖片寬度" & oILS.Width) '測試，提示圖片大小以便判斷單位'此處單位是像素。
            picWidth = oILS.Width
            picHeight = oILS.Height
            If oILS.Width > picMaxWidth Then
                'Word中的尺寸單位默認是cm（厘米），而1cm等於28.35px（像素），由於代碼中換算設置的單位是px（像素）。
                '所以就用尺寸高度或寬度值乘像素值。即為：7*28.35=198.45；寬度換算方法與此相同。
                oILS.Width = Abs(picMaxWidth) '此處單位是厘米。如果Word設置頁邊距為適中，則中間內容寬17.08CM
                '注意：如果此處不設置圖片高度，即使鎖定縱橫比，圖片縱橫比也會改變，不知道為什么？
                oILS.Height = oILS.Width * picHeight / picWidth 'CentimetersToPoints(7)
            End If
            '可能超過寬度調節后，高度還是超出了
            If oILS.Height > picMaxHeight Then
                oILS.Height = Abs(picMaxHeight)
                oILS.Width = oILS.Height * picWidth / picHeight
            End If

            'oILS.Range.Select
            'Selection.ClearFormatting
            'Selection.Range.Paragraphs.Alignment = wdAlignParagraphCenter
            With oILS
                .Range.ParagraphFormat.Reset
                '.Range.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle '單倍行距
                .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter '居中
            End With
        End If
    Next
End Sub

上述代碼注意兩點，一是即使設置了鎖定縱橫比，如果只設置了寬度或者高度其一，圖片依然沒有等比例縮小，所以高度和寬度都要設置才行。

二是寬度縮小后，高度仍可能超出頁面，所以還需要對高度再檢查和縮小一次。

2020/4/19第N次更新。