セルの範囲を画像として保存するVBA

セルの範囲を画像として保存するVBA

savePicture(セル範囲,ファイル名)で
選択したセル範囲の表を画像として保存するマクロを作成。

このマクロを実行すると、カレントフォルダに"pic"フォルダが生成され
"pic"フォルダ内に画像が出力されるようになっている。

また、下記のサンプルコードではfor文を用いて
一定間隔で繰り返しの画像保存をしている。

SaveRangeAsPic.bas

Sub SaveRangeAsPic()

Dim FileName As String
Dim num As Integer
Dim i As Integer: Dim j As Integer
Dim row As Integer: Dim col As Integer

Const width As Integer = 3
Const height As Integer = 6

For j = 0 To 10
    For i = 0 To 2
        FileName = j & "_" & i
        row = 1 + 2 * j: col = 2 + 3 * i
        Call savePicture(Range(Cells(row, col), Cells(row + width, col + height)), FileName)
    Next
Next

End Sub

function savePicture(rng As Range, picName As String)
    Dim FileSize As Long
    Dim pic As ChartObject
    Dim picFolder As String: picFolder = "pic"
    picName = picName & ".png"

    If Dir(picFolder, vbDirectory) = "" Then
        MkDir picFolder
    End If
    
    '■セル範囲を画像データでコピーする。
    rng.CopyPicture
       
    '■指定したセル範囲と同じサイズのpicを新規作成し、保存する。
    Set pic = ActiveSheet.ChartObjects.Add(0, 0, rng.width, rng.height)
    pic.Chart.Export ThisWorkbook.Path & "\" & picFolder & "\" & picName
    FileSize = FileLen(ThisWorkbook.Path & "\" & picFolder & "\" & picName)
     
    '■picのFileSizeを超えるまでループする(画像データが出来上がったら終了する)
    Do Until FileLen(ThisWorkbook.Path & "\" & picFolder & "\" & picName) > FileSize
        pic.Chart.Paste
        pic.Chart.Export ThisWorkbook.Path & "\" & picFolder & "\" & picName
        DoEvents
    Loop
    '■作成完了後、pic削除。
    pic.Delete
    Set pic = Nothing
 
End function