画像ファイルからExcelでドット絵を作成したい！2024年版

画像ファイルをExcelワークシートのセルドット絵にする必要があり、過去に作っていたツールを改善しました。セルをドットと見立てて、行高さと列幅を合わせて正方形にしたセルの背景色を書き換えて描画するものです。

これまでのツールは、24ビットBMPファイルにのみ対応していました。これは、BMPファイルは画像データが左下から右上に向かって配置され、各ピクセルごとに3バイト（RGBデータ）を使用して色情報を記録しているため、処理が行いやすかったためです。このファイル形式であれば、画像ファイルを直接バイナリ形式で読み込み、取得したピクセルの色RGB情報をExcelのセルの背景色（Interior.colorプロパティ）にRGB関数を使用して設定するだけの単純なコードで、セルを使用したドット絵が作成できます。このシンプルさから、24ビットBMPフォーマットのみを対象としていたわけです。

当初より、JPEGやPNGなど他の画像形式に対応したいと考えていましたが、これらのフォーマットを解析し展開する必要があり大変そう、実務上も手動でBMPに変換すれば事足りるので対応を見送っていました。今回、ExcelのChartオブジェクトに任意の画像形式をエクスポートする機能があることを思い出し、この機能を利用して、任意の画像ファイルを24ビットBMP形式に変換し、それを今まで同様のプログラムで処理することで、さまざまな画像形式のファイルをサポートすることができるようになりました。

「Excelドット絵作成ツール」をダウンロード

コードは次の通りです。

'*****************************************
'　Excelドット絵作成 2024
'　https://vbavb.com
'  https://dqw.xlsgm.net
'*****************************************
'BMPデータ構造メモ
'　19　横画数下位バイト'　20 横画数上位バイト'　23　縦画数下位バイト'　24　縦画数上位バイト
'  55 色データ開始'  55　Ｒ'  56　Ｇ'  57　Ｂ'  １ラインの終わりには4の倍数に合わせ００が入る
'  データは左下→右下'　  　　　左上→右上

Option Explicit
Option Base 1

Sub FileOpen()

    Dim x, y, XP, YP, i As Long
    Dim DWcount As Byte
    Dim count, count2 As Long
    Dim R() As Long
    Dim G() As Long
    Dim B() As Long
    
    Dim FileName As Variant    '対象ファイルのパス
    Dim DataBuf() As Byte     'ファイルのバイナリー収容配列

    ChDir ThisWorkbook.Path
    Workbooks.Add

'初期シート設定
    With Cells
        .ColumnWidth = 24 * 0.104
        .RowHeight = 24 * 0.75
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Size = 18
    End With
    ActiveWindow.Zoom = 10
        
    '本ワークブックが保存されているフォルダーに存在するファイルを順に取得
    Dim buf As String
    buf = Dir(ThisWorkbook.Path & "\*.*")
    
    If buf = "" Then
        MsgBox "ファイルがありません"
        Exit Sub
    End If
        
    Dim ws As Worksheet, pic As Picture, chrt As ChartObject, n As Long

    Do While buf <> ""
        
        Application.ScreenUpdating = False
        FileName = ThisWorkbook.Path & "\" & buf
        
        If isImage(buf) Then
            n = n + 1
            'Excelのチャートを使用し24bitBMPに変換
            Set ws = Worksheets.Add
            Set pic = ws.Pictures.Insert(FileName)
            pic.CopyPicture    '画像を挿入しコピー
            Set chrt = ws.ChartObjects.Add(pic.Left, pic.Top, pic.Width, pic.Height)
            DoEvents
            'チャート内の画像貼り付け完了チェックのループ
            Do While chrt.Chart.Shapes.count = 0
                chrt.Chart.Paste    'チャート内に貼り付け
                DoEvents
            Loop
            FileName = FileName & ".bmp"
            chrt.Chart.Export FileName, "bmp"      'bmp形式で保存
            Application.DisplayAlerts = False
            ws.Delete
            
            '休憩
            For i = 1 To 100
                DoEvents
            Next i
            
            '初期シートをコピー
            Worksheets(1).Copy After:=Sheets(Worksheets.count)
            ActiveSheet.Name = Format(Replace(Replace(buf, "bmp", ""), "Image", ""), "000")
            [A1].Select
                 
            'データバッファを用意
            If FileLen(FileName) > 0 Then
                ReDim DataBuf(1 To FileLen(FileName)) As Byte
            Else
                Exit Sub
            End If
            
            '画像ファイルをバイナリーで開く
            Open FileName For Binary As #1
                Get #1, , DataBuf
            Close #1
        
            If DataBuf(29) <> 24 Then
                MsgBox "24bitのBMPのみ対応です"
                Exit Sub
            End If
    
            '画像縦横画素数
            XP = DataBuf(20) * 256 + DataBuf(19)
            YP = DataBuf(24) * 256 + DataBuf(23)
        
            Select Case ((XP * 3) Mod 4)
                Case 0
                    DWcount = 0
                Case 1
                    DWcount = 3
                Case 2
                    DWcount = 2
                Case 3
                    DWcount = 1
            End Select
        
            'RGB配列に格納
            ReDim R(1 To YP, 1 To XP) As Long
            ReDim G(1 To YP, 1 To XP) As Long
            ReDim B(1 To YP, 1 To XP) As Long
        
            For y = YP To 1 Step -1
                For x = 1 To XP
                    count = (y - 1) * (XP * 3 + DWcount)
                    count2 = (x - 1) * 3 + 54
                    B(YP + 1 - y, x) = DataBuf(count + count2 + 1)
                    G(YP + 1 - y, x) = DataBuf(count + count2 + 2)
                    R(YP + 1 - y, x) = DataBuf(count + count2 + 3)
                Next x
            Next y
        
            'セルの背景色に設定
            With ActiveSheet
                For x = 1 To XP
                    For y = 1 To YP
                        Cells(y, x).Interior.Color = RGB(R(y, x), G(y, x), B(y, x))
                    Next y
                Next x
            End With
        
            '変換したBMPを削除
            Kill FileName
        
        End If
        
        '次の画像へ
        buf = Dir()
    Loop
    
    Application.ScreenUpdating = True
            
    If n > 0 Then
        MsgBox n & "枚の画像をExcelドット絵に変換しました"
    Else
        MsgBox "Excelドット絵に変換できる画像がありませんでした"
    End If
    
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

'*****************************************

'　Excelドット絵作成 2024

'　https://vbavb.com

' https://dqw.xlsgm.net

'*****************************************

'BMPデータ構造メモ

'　19　横画数下位バイト'　20 横画数上位バイト'　23　縦画数下位バイト'　24　縦画数上位バイト

' 55 色データ開始' 55　Ｒ' 56　Ｇ' 57　Ｂ' １ラインの終わりには4の倍数に合わせ００が入る

' データは左下→右下'　　　　左上→右上

Option Explicit

Option Base 1

Sub FileOpen()

Dim x, y, XP, YP, i As Long

Dim DWcount As Byte

Dim count, count2 As Long

Dim R() As Long

Dim G() As Long

Dim B() As Long

Dim FileName As Variant '対象ファイルのパス

Dim DataBuf() As Byte 'ファイルのバイナリー収容配列

ChDir ThisWorkbook.Path

Workbooks.Add

'初期シート設定

With Cells

.ColumnWidth = 24 * 0.104

.RowHeight = 24 * 0.75

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.Font.Size = 18

End With

ActiveWindow.Zoom = 10

'本ワークブックが保存されているフォルダーに存在するファイルを順に取得

Dim buf As String

buf = Dir(ThisWorkbook.Path & "\*.*")

If buf = "" Then

MsgBox "ファイルがありません"

Exit Sub

End If

Dim ws As Worksheet, pic As Picture, chrt As ChartObject, n As Long

Do While buf <> ""

Application.ScreenUpdating = False

FileName = ThisWorkbook.Path & "\" & buf

If isImage(buf) Then

n = n + 1

'Excelのチャートを使用し24bitBMPに変換

Set ws = Worksheets.Add

Set pic = ws.Pictures.Insert(FileName)

pic.CopyPicture '画像を挿入しコピー

Set chrt = ws.ChartObjects.Add(pic.Left, pic.Top, pic.Width, pic.Height)

DoEvents

'チャート内の画像貼り付け完了チェックのループ

Do While chrt.Chart.Shapes.count = 0

chrt.Chart.Paste 'チャート内に貼り付け

DoEvents

Loop

FileName = FileName & ".bmp"

chrt.Chart.Export FileName, "bmp" 'bmp形式で保存

Application.DisplayAlerts = False

ws.Delete

'休憩

For i = 1 To 100

DoEvents

Next i

'初期シートをコピー

Worksheets(1).Copy After:=Sheets(Worksheets.count)

ActiveSheet.Name = Format(Replace(Replace(buf, "bmp", ""), "Image", ""), "000")

[A1].Select

'データバッファを用意

If FileLen(FileName) > 0 Then

ReDim DataBuf(1 To FileLen(FileName)) As Byte

Else

Exit Sub

End If

'画像ファイルをバイナリーで開く

Open FileName For Binary As #1

Get #1, , DataBuf

Close #1

If DataBuf(29) <> 24 Then

MsgBox "24bitのBMPのみ対応です"

Exit Sub

End If

'画像縦横画素数

XP = DataBuf(20) * 256 + DataBuf(19)

YP = DataBuf(24) * 256 + DataBuf(23)

Select Case ((XP * 3) Mod 4)

Case 0

DWcount = 0

Case 1

DWcount = 3

Case 2

DWcount = 2

Case 3

DWcount = 1

End Select

'RGB配列に格納

ReDim R(1 To YP, 1 To XP) As Long

ReDim G(1 To YP, 1 To XP) As Long

ReDim B(1 To YP, 1 To XP) As Long

For y = YP To 1 Step -1

For x = 1 To XP

count = (y - 1) * (XP * 3 + DWcount)

count2 = (x - 1) * 3 + 54

B(YP + 1 - y, x) = DataBuf(count + count2 + 1)

G(YP + 1 - y, x) = DataBuf(count + count2 + 2)

R(YP + 1 - y, x) = DataBuf(count + count2 + 3)

Next x

Next y

'セルの背景色に設定

With ActiveSheet

For x = 1 To XP

For y = 1 To YP

Cells(y, x).Interior.Color = RGB(R(y, x), G(y, x), B(y, x))

Next y

Next x

End With

'変換したBMPを削除

Kill FileName

End If

'次の画像へ

buf = Dir()

Loop

Application.ScreenUpdating = True

If n > 0 Then

MsgBox n & "枚の画像をExcelドット絵に変換しました"

Else

MsgBox "Excelドット絵に変換できる画像がありませんでした"

End If

End Sub

'対象画像形式の判定
Function isImage(FileName As String) As Boolean
    '3文字拡張子
    Select Case LCase(Right(FileName, 4))
        Case ".jpg", ".png", ".bmp", ".gif", ".tif", ".tiff", ".emf", ".wmf"
            isImage = True
    End Select
    '4文字拡張子
    Dim kks As String
    kks = LCase(Right(FileName, 5))
    If kks = ".jpeg" Or kks = ".tiff" Then isImage = True
End Function

'対象画像形式の判定

Function isImage(FileName As String) As Boolean

'3文字拡張子

Select Case LCase(Right(FileName, 4))

Case ".jpg", ".png", ".bmp", ".gif", ".tif", ".tiff", ".emf", ".wmf"

isImage = True

End Select

'4文字拡張子

Dim kks As String

kks = LCase(Right(FileName, 5))

If kks = ".jpeg" Or kks = ".tiff" Then isImage = True

End Function

簡単に解説すると、ワークブックが保存されている同じフォルダ内の画像ファイルを使用して、ワークシート上でドット絵を作成する処理となっています。まず、対象の画像ファイルが存在する場合、ワークブックに新しいシートを追加し、そのシートに画像を挿入します。次に、Chartオブジェクトを使用して画像を適切に配置し、画像がぴったり収まるようにChartオブジェクトのサイズを画像のサイズに合わせます。画像の配置が完了した後、画像をBMPフォーマットでエクスポートし、このエクスポートされたBMPファイルを使用してドット絵の生成処理を実行します。このプロセスを通じて、様々な形式の画像をExcelのドット絵として再現することが可能になりました。

多量の、そして様々ファイル形式の画像を一括して、Excelドット絵に変換したい場合に、とても便利だと思いますが、そのような機会が訪れることは、あまりないかもしれません（笑）。

それでは、よいVBAライフを！

【2024/02/25　追記】
「Excelドット絵2024」を活用して、ドラクエ4のバトランド城を歩き回れるワークブックを、こちらにエントリーしました。ファイルをダウンロードいただけます。
https://dqw.xlsgm.net/dq4/