ハピタス登録で1,000円分になるURL
パワポの画像だけ縮小VBAマクロ
こうなる
超便利。
何ができるか
こんなパワポがあったとして
100ページくらいあるスライド全ての画像サイズを半分にしたいとする。
まずは左上「ファイル」→「その他」→「オプション」から
リボンのユーザー設定→メインタブ→開発 にチェック→OK
Visual Basicをクリックして…
VBAProjectを右クリック→挿入→標準モジュール
ソースコード（この記事の末尾にあり）をペタっと貼り付けて
保存。
あとは、マクロ→実行すると…
画像がキュッっと小さくなる！
最高。
驚愕のChatGPT
このソースができるまでのChatGPTとのやりとり
エラーが出たよと教えて改善を促すと
治しよる。
しかし更にエラーが出たぜと伝える。
改善してきよった。
なおもエラーが出る。3度目の正直なるか。
動いた！
しかし、縮小前の元画像も残って重なっちゃった。これじゃサイズは小さくならない。
元画像を削除する考慮が漏れている？または無限ループしている？
さらに改善を促す。
スゴイ。ほぼ治った。あとはちょっと手修正を加えた。以下ソースコード。
ソースコード
Sub ReduceImageResolution7()
Dim slide As slide
Dim shape As shape
Dim pic As ShapeRange
' 解像度を下げる倍率
Dim reductionFactor As Double
reductionFactor = 0.5 ' 50%に減らす例
For Each slide In ActivePresentation.Slides
For Each shape In slide.Shapes
If shape.Type = msoPicture Then
Set pic = slide.Shapes.Range(Array(shape.Name))
pic.Export Environ("TEMP") & "\temp.jpg", ppSaveAsJPG
Set pic = Nothing
' もとの形状のサイズと位置を変数に保存する
Dim oldLeft As Single
Dim oldTop As Single
Dim oldWidth As Single
Dim oldHeight As Single
oldLeft = shape.Left
oldTop = shape.Top
oldWidth = shape.Width
oldHeight = shape.Height
' 新しい形状を追加する
Set shape2 = slide.Shapes.AddPicture(Environ("TEMP") & "\temp.jpg", msoFalse, msoTrue, oldLeft, oldTop, oldWidth, oldHeight)
'shape.Select
With shape2
.ScaleWidth reductionFactor, msoFalse, msoScaleFromTopLeft
.ScaleHeight reductionFactor, msoFalse, msoScaleFromTopLeft
End With
' もとの形状を削除する
shape.Delete
Kill Environ("TEMP") & "\temp.jpg"
End If
Next shape
Next slide
End Sub
