セルをPNG画像として保存する
表を選択し図としてコピーする→貼り付ける→
ファイルをhtmlで名前を付けて保存する→htmlファイルと画像を納めたフォルダが出来る
セルに表示されている内容をそのまま画像としたい場合があります。
他の資料の材料としたい場合などですね。
Excelでの操作は以下の手順になります。
1.画像化したいセル範囲を選択します。
2.ホームタブ→コピー→図としてコピー を選択します。
3.図のコピーダイアログで、画面に合わせる、ピクチャを選択してOKを押します。
4.ホームタブ→貼り付け→形式を選択して貼り付け を選択して、図（拡張メタファイル）でOKを押します。
5.ファイル→名前を付けて保存 でダイアログを開きます。
6.ファイルの種類でhtmlを選択します。
7.上書き保存で再発行（または発行）を選択して、保存ボタンを押します。
8.Webページとして発行ダイアログで、OKを押します。
9.保存先のフォルダに～filesというフォルダが出来ているのでその中にPNGファイルが作成されています。
【ソースコード】
セルをPNG画像に変換して保存する関数です。
引数が３つあり、それぞれ、引数1＝作成するPNGファイルを保存するフォルダ、引数2＝PNG画像に変換する単一セルまたは結合セル、引数3＝省略可。作成するPNGファイル名の先頭文字列 を指定します。
filesフォルダに「A1_image001.png」という形式のファイルが作成されます。
引数rが単一セルまたは結合セルを指している場合はxx_image001.pngを採用します。セル範囲を指している場合はxx_image004.pngなのかxx_image999.pngなのかどれが正解なのか判別できないためfilesフォルダを残したままにしています。
引数が３つあり、それぞれ、引数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
【テストコード】
上の関数を呼び出すテストコードです。
5行目のループは選択範囲を各セルごとにPNGファイル化しています。
6行目と7行目が上の関数を呼び出す部分です。6行目はコメントアウトしていますが、PNGファイル名の先頭文字を3番目の引数として渡しています。7行目のように省略しても構いません。省略時はPNGファイル名の先頭に「PNG_」と付きます。
11行目は選択範囲をPNGファイル化しています。
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
