VBAで図を圧縮する2つの方法

2021年3月18日2021年11月6日

VBAの図って、セル（Range）と比べると扱い方が難しいですよね。

そんな扱いづらい図ですが、操作方法は限られているのでコードを数パターン覚えておけば後は応用が利きます。（基本的にShapesコレクションからShapeオブジェクトを取り出す）

今回は図を圧縮する2つの方法を紹介します。

シート内の全ての図を電子メール用に圧縮
シート内の全ての図をJPEGに変換

の2つを紹介するのでVBAで図の圧縮をしたい人は参考にしてみてください。

シート内の全ての図を電子メール用に圧縮

Sub PicCompression1()
'アクティブシート上の図を電子メール用に圧縮
    Dim oneShp As Shape
    Dim pasteLeft As Double, pasteTop As Double
    For Each oneShp In ActiveSheet.Shapes
        If oneShp.Type = msoPicture Then
            oneShp.Select
            Application.SendKeys "%e~" '[電子メール用 (96 ppi)]を選択
            Application.CommandBars.ExecuteMso "PicturesCompress"
        End If
    Next
End Sub

こちらのプログラムは「図の形式」タブにある「図の圧縮」を使用しています。
※Sendkeysメソッドを使用しているため、稀に失敗するかもしれません。

このマクロを使えば、アクティブシート上の全ての画像を電子メール用（96ppi）に圧縮することができます。

シート内の全ての図をJPEGに変換

Sub PicCompression2()
'アクティブシート上の図をJPEG形式に変換
    
    Dim oneShp As Shape
    Dim pasteLeft As Double, pasteTop As Double
    For Each oneShp In ActiveSheet.Shapes
        If oneShp.Type = msoPicture Then
            pasteLeft = oneShp.Left
            pasteTop = oneShp.Top
            oneShp.Cut
        
            'JPEG形式で貼付け
            ActiveSheet.PasteSpecial Format:="図 (JPEG)", link:=False, displayasicon:=False
            DoEvents
            With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
                .Left = pasteLeft
                .Top = pasteTop
            End With
        End If
    Next
End Sub

このプログラムではPasteSpecialメソッドを用いて、図の形式をJPEG変換しています。
こちらはエクセルのメソッドなので動作は安定しています。

図の位置が変わらないようにpasteLeft, pasteTopという変数で図の位置を記録しています。

図（画像）によってそれぞれの方法で圧縮される量が違うと思うので、どの程度圧縮されるか一度試してみて、良い方法を採用してみてください。

プログラム内で使用しているTypeプロパティついては、こちらの記事を参照ください。