Power PointのVBAを使って複数の画像を一括でリサイズ

作った経緯

• 会社のセキュリティ上指定のソフトウェア以外は申請無しでインストールできない、申請に時間がかかる…
  という状況の方もいらっしゃるかと思います。
  そんな方にPower PointのVBAを使った画像サイズ変更方法を紹介します。

コード

画像一括リサイズ

Sub 画像縮小_各画像サイズ対応()

    Dim folderPath As String
    Dim fileName As String
    Dim fd As FileDialog

    ' ===== 設定 =====
    Dim scaleRatio As Double
    Dim suffix As String

    scaleRatio = 0.5
    suffix = "_変換後"      ' 作成した画像ファイルの追加文字列
    ' =================

    ' フォルダ選択
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)

    If fd.Show = False Then Exit Sub
    folderPath = fd.SelectedItems(1) & "\"
    fileName = Dir(folderPath & "*.jpg")

    If fileName = "" Then
        MsgBox "画像が見つかりません"
        Exit Sub
    End If
    
    ' 空のパワーポイントファイル作成
    Dim pres As Presentation
    Set pres = Presentations.Add(msoTrue)

    Dim sld As Slide
    Dim shp As Shape
    Dim orgW As Double
    Dim orgH As Double
    Dim newW As Double
    Dim newH As Double

    ' ===== メイン処理 =====
    Do While fileName <> ""

        ' スライド作成
        Set sld = pres.Slides.Add(1, ppLayoutBlank)
        
        ' スライドサイズの指定
        With pres.PageSetup
            .SlideWidth = 10000
            .SlideHeight = 10000
        End With
        
        ' 画像貼り付け
        Set shp = sld.Shapes.AddPicture( _
            fileName:=folderPath & fileName, _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=0, _
            Top:=0)
        
        ' 元サイズ取得
        orgW = shp.Width
        orgH = shp.Height
        
        '画像サイズ計算
        newW = orgW * scaleRatio
        newH = orgH * scaleRatio

        ' サイズ設定
        shp.Width = newW
        shp.Height = newH
        
        ' 左上に寄せる_寄せない場合余白が入る可能性がある
        shp.Left = 0
        shp.Top = 0

        ' 保存名
        Dim baseName As String
        baseName = Left(fileName, InStrRev(fileName, ".") - 1)

        Dim savePath As String
        savePath = folderPath & baseName & suffix & ".jpg"

        ' 画像オブジェクトだけを書き出す
        shp.Export savePath, ppShapeFormatJPG

        ' スライド削除
        sld.Delete
        
        fileName = Dir

        DoEvents

    Loop
    ' =====================

    ' 作成したパワーポイント削除
    pres.Close

    MsgBox "保存が完了しました。"

End Sub

コードの解説

• scaleRatioで画像の縦横を何倍にするか指定します。
• fileNameの"jpg"を変えれば、別の拡張子が読み込めます。
• 実行するとフォルダ選択画面になり、選択したフォルダ内のjpg画像をリサイズします。
• 処理の流れは、空のパワーポイントを立ち上げ後、スライドを追加→画像貼り付け→画像リサイズ→画像保存→スライド削除　を画像の枚数分だけ繰り返しになります。
• 元々の画像が保存されているフォルダにリサイズした画像を保存します。ファイル名はファイル名_変換後で出力されます。末尾の文字列"_変換後"は変数suffixを変えれば文字列も変わります。

注意点

• 画像サイズ>スライドサイズの場合、画像サイズ＝スライドサイズになり、元の画像サイズが変わってしまいます。そのため、スライドサイズを大きめの縦横10000に指定してます。
• 保存される画像のdpiが96固定なので、画像の元々のdpiに応じて画像サイズが変わります。
  式：元々の縦or横画像サイズ × scaleRatio × 元々のdpi ÷ 96 =変更後の縦or横画像サイズ

計算結果

フリー素材.comの画像を使って検証してみました。
愛用していたスキマナースはアクセスできませんでした…
フリー素材.com：https://www.free-materials.com/
スキマナース（アクセス不可）：https://nurse-web.jp/photo/

• scaleRatio=0.5で計算
• サンゴの画像は縦横サイズ4032×3024→2688×2016、dpi72→96に変化
• 馬の画像は縦横サイズ5500×4500→880×720、dpi300→96に変化。dpi減少により指定スケールよりも画像サイズが小さくなる。
  
  

実行方法

Power Pointを開いて、ファイル→その他→オプション

リボンのユーザー設定→右のウィンドウの開発にチェックを入れてOK

リボンに開発タブが追加されるので、開発タブのVisual Basicをクリック

挿入の標準モジュールをクリック

Module1をダブルクリックして、右側のエディターに上記のコードを貼り付け

コードを貼り付けたら再生▶ボタンをクリックで実行

感想

• パワポ特有のスライドの特性？もあって、思ったよりも大変でした。でも楽しかったです。
• 横幅を指定＆縦幅は縦横比で決める処理も検討したのですが、最初に処理した画像サイズの縦幅でなぜか固定されるので止めました…
• WindowsのPowerShellでも画像サイズ変更できるので、普通にコッチがおすすめです(泣)
  https://qiita.com/miyamiya/items/d1a975fb6618d46eda0c