セルをPNG画像として保存する｜ Excel作業をVBAで効率化

セルの内容を画像のPNGファイルで保存することが可能

セルに表示されている内容をそのまま画像としたい場合があります。

他の資料の材料としたい場合などですね。

Excelでの操作は以下の手順になります。

画像化したいセル範囲を選択します。
ホームタブ→コピー→図としてコピー　を選択します。
図のコピーダイアログで、画面に合わせる、ピクチャを選択してOKを押します。
ホームタブ→貼り付け→形式を選択して貼り付け　を選択して、図（拡張メタファイル）でOKを押します。
ファイル→名前を付けて保存　でダイアログを開きます。
ファイルの種類でhtmlを選択します。
上書き保存で再発行（または発行）を選択して、保存ボタンを押します。
Webページとして発行ダイアログで、OKを押します。
保存先のフォルダに～filesというフォルダが出来ているのでその中にPNGファイルが作成されています。

以下のマクロはセルの表示内容をPNG画像として保存します。

ソースコード

セルをPNG画像に変換して保存する関数です。

引数が３つあり、それぞれ、引数1＝作成するPNGファイルを保存するフォルダ、引数2＝PNG画像に変換する単一セルまたは結合セル、引数3＝省略可。作成するPNGファイル名の先頭文字列　を指定します。

filesフォルダに「A1_image001.png」という形式のファイルが作成されます。

引数rが単一セルまたは結合セルを指している場合はxx_image001.pngを採用します。セル範囲を指している場合はxx_image004.pngなのかxx_image999.pngなのかどれが正解なのか判別できないためfilesフォルダを残したままにしています。

'// 引数1：sSaveDir＝作成するPNGファイルを保存するフォルダ
'// 引数2：r As Range＝PNG画像に変換するセル。単一セルまたは結合セルを指定する。
'// 引数3：Optional sFileName = "PNG_"＝作成するPNGファイルのファイル名の先頭文字列。省略可。
Sub CellToPng(sSaveDir, r As Range, Optional sFileName = "PNG_")
    Dim oFso            As FileSystemObject
    Dim sDir                                '// 作成フォルダの一部
    Dim sHtmPath                            '// HTMLファイルのフルパス
    Dim oShape                              '// 貼り付けたセルの図
    Dim sAddress                            '// 座標指定用のセル範囲アドレス
    Dim sAddressStr                         '// ファイル名用のセルアドレス
    Dim sPngFileName                        '// PNGファイル名
    
    Application.ScreenUpdating = False
    
    '// 単一セルの場合
    If (r.Count = 1) Then
        '// 結合セルの場合
        If (r.MergeArea.Count > 1) Then
            '// セル範囲アドレスを取得(A1:B2形式)
            sAddress = r.MergeArea.Address(False, False)
            
            '// 引数のセルが結合セルの左上のセルではない場合
            If (Left(sAddress, Len(r.Address(False, False))) <> r.Address(False, False)) Then
                Exit Sub
            End If
        '// 単一セルの場合
        Else
            '// セルアドレスを取得(A1形式)
            sAddress = r.Address(False, False)
        End If
    '// セル範囲の場合
    Else
        sAddress = r.Address(False, False)
    End If
    
    sAddressStr = Replace(sAddress, ":", "")
    
    '// 対象セル範囲を画像としてコピー
    Range(sAddress).CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    '// 図として貼り付け（オートシェイプ化）
    ActiveSheet.PasteSpecial Format:="図 (拡張メタファイル)", Link:=False, DisplayAsIcon:=False
    
    '// 図を移動
    Set oShape = Selection
    oShape.Top = r.Top
    oShape.Left = r.Left
    
    '// HTMLファイル名を設定
    sFileName = Replace(sFileName, "/", "\")
    sFileName = Replace(sFileName, "\", "")
    sSaveDir = Replace(sSaveDir, "/", "\")
    If (Right(sSaveDir, 1) = "\") Then
        sSaveDir = Mid(sSaveDir, 1, Len(sSaveDir) - 1)
    End If
    sDir = sSaveDir & "\" & sFileName & sAddressStr
    sDir = Replace(sDir, "/", "\")
    sDir = Replace(sDir, "\\", "\")
    sHtmPath = sDir & ".htm"
    
    '// HTML形式で保存（ファイル名にセルアドレスを付与する）
    With ActiveWorkbook.PublishObjects.Add(xlSourceRange, sHtmPath, r.Parent.Name, r.Address, xlHtmlStatic, sAddressStr)
        .Publish (True)
        .AutoRepublish = False
    End With
    
    '// 作成したオートシェイプを削除
    Selection.Delete
    
    '// 単一セル指定の場合（セル範囲の場合はPNGファイルが複数出力され、image_xxx.pngのどれが正しいのか不明のため選別しない）
    If (r.Count = 1) Then
        Set oFso = New FileSystemObject
        sPngFileName = sAddressStr & "_image001.png"
        
        '// 既に作成済みの場合は再作成するため削除する
        If (oFso.FileExists(sSaveDir & "\" & sPngFileName) = True) Then
            Call oFso.DeleteFile(sSaveDir & "\" & sPngFileName)
        End If
        
        '// PNGファイルを移動（PNG_A1.filesフォルダから上階層に移動）
        Call oFso.MoveFile(sDir & ".files\" & sPngFileName, sSaveDir & "\" & sPngFileName)
        
        '// PNG_A1.filesフォルダを削除
        Kill sDir & ".files\*"
        RmDir sDir & ".files"
    End If
    
    '// .htmファイルを削除
    Kill sHtmPath
    
    Application.ScreenUpdating = True
End Sub

'// 引数1：sSaveDir＝作成するPNGファイルを保存するフォルダ

'// 引数2：r As Range＝PNG画像に変換するセル。単一セルまたは結合セルを指定する。

'// 引数3：Optional sFileName = "PNG_"＝作成するPNGファイルのファイル名の先頭文字列。省略可。

Sub CellToPng(sSaveDir, r As Range, Optional sFileName = "PNG_")

Dim oFso As FileSystemObject

Dim sDir '// 作成フォルダの一部

Dim sHtmPath '// HTMLファイルのフルパス

Dim oShape '// 貼り付けたセルの図

Dim sAddress '// 座標指定用のセル範囲アドレス

Dim sAddressStr '// ファイル名用のセルアドレス

Dim sPngFileName '// PNGファイル名

Application.ScreenUpdating = False

'// 単一セルの場合

If (r.Count = 1) Then

'// 結合セルの場合

If (r.MergeArea.Count > 1) Then

'// セル範囲アドレスを取得(A1:B2形式)

sAddress = r.MergeArea.Address(False, False)

'// 引数のセルが結合セルの左上のセルではない場合

If (Left(sAddress, Len(r.Address(False, False))) <> r.Address(False, False)) Then

Exit Sub

End If

'// 単一セルの場合

Else

'// セルアドレスを取得(A1形式)

sAddress = r.Address(False, False)

End If

'// セル範囲の場合

Else

sAddress = r.Address(False, False)

End If

sAddressStr = Replace(sAddress, ":", "")

'// 対象セル範囲を画像としてコピー

Range(sAddress).CopyPicture Appearance:=xlScreen, Format:=xlPicture

'// 図として貼り付け（オートシェイプ化）

ActiveSheet.PasteSpecial Format:="図 (拡張メタファイル)", Link:=False, DisplayAsIcon:=False

'// 図を移動

Set oShape = Selection

oShape.Top = r.Top

oShape.Left = r.Left

'// HTMLファイル名を設定

sFileName = Replace(sFileName, "/", "\")

sFileName = Replace(sFileName, "\", "")

sSaveDir = Replace(sSaveDir, "/", "\")

If (Right(sSaveDir, 1) = "\") Then

sSaveDir = Mid(sSaveDir, 1, Len(sSaveDir) - 1)

End If

sDir = sSaveDir & "\" & sFileName & sAddressStr

sDir = Replace(sDir, "/", "\")

sDir = Replace(sDir, "\\", "\")

sHtmPath = sDir & ".htm"

'// HTML形式で保存（ファイル名にセルアドレスを付与する）

With ActiveWorkbook.PublishObjects.Add(xlSourceRange, sHtmPath, r.Parent.Name, r.Address, xlHtmlStatic, sAddressStr)

.Publish (True)

.AutoRepublish = False

End With

'// 作成したオートシェイプを削除

Selection.Delete

'// 単一セル指定の場合（セル範囲の場合はPNGファイルが複数出力され、image_xxx.pngのどれが正しいのか不明のため選別しない）

If (r.Count = 1) Then

Set oFso = New FileSystemObject

sPngFileName = sAddressStr & "_image001.png"

'// 既に作成済みの場合は再作成するため削除する

If (oFso.FileExists(sSaveDir & "\" & sPngFileName) = True) Then

Call oFso.DeleteFile(sSaveDir & "\" & sPngFileName)

End If

'// PNGファイルを移動（PNG_A1.filesフォルダから上階層に移動）

Call oFso.MoveFile(sDir & ".files\" & sPngFileName, sSaveDir & "\" & sPngFileName)

'// PNG_A1.filesフォルダを削除

Kill sDir & ".files\*"

RmDir sDir & ".files"

End If

'// .htmファイルを削除

Kill sHtmPath

Application.ScreenUpdating = True

End Sub

テストコード

上の関数を呼び出すテストコードです。

5行目のループは選択範囲を各セルごとにPNGファイル化しています。

6行目と7行目が上の関数を呼び出す部分です。6行目はコメントアウトしていますが、PNGファイル名の先頭文字を3番目の引数として渡しています。7行目のように省略しても構いません。省略時はPNGファイル名の先頭に「PNG_」と付きます。

11行目は選択範囲をPNGファイル化しています。

Sub CellToPngTest()
    Dim r As Range
    
    '// A1からC1の各セルをPNGファイル化
    For Each r In Selection
'        Call CellToPng("C:\web\test\", r, "\ABC\")
        Call CellToPng("C:\web\test\", r)
    Next
    
    '// A1からC1のセル範囲PNGファイル化
    Call CellToPng("C:\web\test\", Selection)
End Sub

Sub CellToPngTest()

Dim r As Range

'// A1からC1の各セルをPNGファイル化

For Each r In Selection

' Call CellToPng("C:\web\test\", r, "\ABC\")

Call CellToPng("C:\web\test\", r)

'// A1からC1のセル範囲PNGファイル化

Call CellToPng("C:\web\test\", Selection)

End Sub

実行前
セル範囲を選択します。

↓

実行後

個別セル指定のPNGファイル

指定フォルダ直下に各セルのPNGファイルが保存されています。

A1_image001.png
A2_image001.png
A3_image001.png
A4_image001.png
A5_image001.png
A6_image001.png
B1C2_image001.png
B3C4_image001.png
B5C6_image001.png

セル範囲のPNGファイル

セル範囲はどのPNGファイルが正しいのか判定できないためfilesフォルダのまま残しています。

以下のように、004が正解なのですが、正解が004であることを判別する方法が現時点で分かっていません。最終番号の１つ前の番号か？とも思ったのですが、その判別方法はちょっと危ないと思い避けています。判別できる方法はあるとは思うのですが、断念しちゃいました。というよりも、そこまで不便ではないので私はこの状態で使っています。

A1C6_image001.png
A1C6_image002.png
A1C6_image003.png
A1C6_image004.png
A1C6_image005.png