Excelで画像をセルに展開

0.README.md

Excelで画像をセルに展開

概要

Excelで画像を読み込み、セルをドットに見立てて展開するためのモジュール。※動作例はこちら

使い方

1. マクロ有効ブックを作って共通モジュール (Mod_ExtractImageToCells_Common.vba)と本体モジュール (Mod_ExtractImageToCells.vba)をそれぞれ標準モジュールとして貼り付け。
2. マクロを表示して（Alt+F8）CallExtractImageToCellsを実行。
3. 目的の画像ファイルを選択（処理速度の問題から、最大128x128ピクセルまで・それより大きい画像は適当に縮小される）

モジュール一覧

1. 共通モジュール (Mod_ExtractImageToCells_Common.vba)
2. 本体モジュール (Mod_ExtractImageToCells.vba)
3. 比較用モジュール (Mod_ExtractImageToCellsTrial.vba) ※bgcolor 付きのHTMLを作り、Range.PasteSpecial で貼り付け
4. パフォーマンステスト用モジュール (Mod_TestExtractImageToCells.vba)

Mod_ExtractImageToCells.vba

Option Explicit

Function ExtractImageToCells(ImageFileName As String, Optional TargetRange As Range, Optional CellWidthPixels As Long = 1, Optional RowLimit As Long = 0, Optional ColumnLimit As Long = 0, Optional PixelsPerSideOfCell As Long = 0, Optional PixelsToPoints As Double = 0.75) As Range
    Dim WIA As Object: Set WIA = GetWIA(ImageFileName)
    Dim ImageWidth As Long: ImageWidth = WIA.Width
    Dim ImageHeight As Long: ImageHeight = WIA.Height
    Dim ARGBData As Object: Set ARGBData = WIA.ARGBData
    
    If PixelsPerSideOfCell < 1 Then
        ' PixelsPerSideOfCell（各セルの辺に対応するピクセル数）が未指定(0)の場合、列数と行数の制限を元にして自動計算
        Dim CalcPixelsHorizontal As Double: CalcPixelsHorizontal = 1
        Dim CalcPixelsVertical As Double: CalcPixelsVertical = 1
        
        If 0 < ColumnLimit And ColumnLimit < ImageWidth Then
            CalcPixelsHorizontal = ImageWidth / ColumnLimit
        End If
        
        If 0 < RowLimit And RowLimit < ImageHeight Then
            CalcPixelsVertical = ImageHeight / RowLimit
        End If
        
        If CalcPixelsHorizontal < CalcPixelsVertical Then CalcPixelsHorizontal = CalcPixelsVertical
        
        PixelsPerSideOfCell = IIf(CalcPixelsHorizontal - Fix(CalcPixelsHorizontal) = 0, Fix(CalcPixelsHorizontal), Fix(CalcPixelsHorizontal) + 1)
        If PixelsPerSideOfCell < 1 Then PixelsPerSideOfCell = 1
    End If
    
    Dim CurrentRow As Long
    Dim CurrentColumn As Long
    Dim RowMax As Long: RowMax = Fix(ImageHeight / PixelsPerSideOfCell)
    Dim ColumnMax As Long: ColumnMax = Fix(ImageWidth / PixelsPerSideOfCell)
    Dim PixelsPerCell As Long: PixelsPerCell = PixelsPerSideOfCell * PixelsPerSideOfCell
    Dim ImageX As Long, ImageY As Long
    Dim OffsetX As Long, OffsetY As Long
    Dim Red As Long, Green As Long, Blue As Long
    Dim RedSum As Long, GreenSum As Long, BlueSum As Long
    Dim CurrentColorValue As Long
    
    If TargetRange Is Nothing Then Set TargetRange = ActiveWindow.ActiveCell
    
    If 0 < RowLimit And RowLimit < RowMax Then RowMax = RowLimit
    If 0 < ColumnLimit And ColumnLimit < ColumnMax Then ColumnMax = ColumnLimit
    
    Set TargetRange = TargetRange(1, 1).Resize(RowMax, ColumnMax)
    
    Call SetCellSize(CellWidthPixels, TargetRange:=TargetRange, PixelsToPoints:=PixelsToPoints)
    
    For CurrentRow = 1 To RowMax
        For CurrentColumn = 1 To ColumnMax
            ImageX = (CurrentColumn - 1) * PixelsPerSideOfCell
            ImageY = (CurrentRow - 1) * PixelsPerSideOfCell
            RedSum = 0: GreenSum = 0: BlueSum = 0
            For OffsetY = 0 To PixelsPerSideOfCell - 1
                For OffsetX = 0 To PixelsPerSideOfCell - 1
                    Call GetPixelRGB(ARGBData, ImageX + OffsetX, ImageY + OffsetY, ImageWidth, ImageHeight, Red, Green, Blue)
                    RedSum = RedSum + Red: GreenSum = GreenSum + Green: BlueSum = BlueSum + Blue
                Next OffsetX
            Next OffsetY
            CurrentColorValue = RGB(RedSum / PixelsPerCell, GreenSum / PixelsPerCell, BlueSum / PixelsPerCell)
            TargetRange(CurrentRow, CurrentColumn).Interior.Color = CurrentColorValue
        Next CurrentColumn
        If GetInputState() Then DoEvents
    Next CurrentRow

    Set ExtractImageToCells = TargetRange
End Function

Sub CallExtractImageToCells()
    Const CellWidthPixels = 5 ' 展開後の各セルの幅（px単位）
    Const RowLimit = 128 ' 展開行数の制限
    Const ColumnLimit = 128 '展開列数の制限
    Const PixelsPerSideOfCell = 0 ' 1つのセルの辺に対応する画像のピクセル数（0: 自動計算）
    
    Dim ImageFileName As Variant
    
    ImageFileName = Application.GetOpenFilename(FileFilter:="画像ファイル,*.bmp;*.jpg;*.jpeg;*.gif;*.png")
    If ImageFileName = False Then
        Exit Sub
    End If
    
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    ExtractImageToCells(CStr(ImageFileName), CellWidthPixels:=CellWidthPixels, RowLimit:=RowLimit, ColumnLimit:=ColumnLimit, PixelsPerSideOfCell:=PixelsPerSideOfCell).Select

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Mod_ExtractImageToCells_Common.vba

Option Explicit

#If VBA7 And Win64 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)
    Declare PtrSafe Function GetInputState Lib "user32" () As Long
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
    Declare Function GetInputState Lib "user32" () As Long
#End If


Function GetWIA(ImageFileName) As Object
    Dim WIA As Object: Set WIA = CreateObject("WIA.ImageFile") ' WIA = Windows Image Acquisition
    
    If WIA Is Nothing Then
        Set GetWIA = Nothing
        Exit Function
    End If
    
    Call WIA.LoadFile(ImageFileName)
    
    Set GetWIA = WIA
End Function

Function GetPixelColorValue(ARGBData As Object, x As Long, y As Long, Width As Long, Height As Long, Optional IsForCell As Boolean = True) As Long
    Dim ColorValue As Long
    
'    If x < 0 Or Width <= x Or y < 0 Or Height <= y Then
'        GetPixelColorValue = 0
'        Exit Function
'    End If

    If x < 0 Then x = 0 Else: If Width <= x Then x = Width - 1
    If y < 0 Then y = 0 Else: If Height <= y Then y = Height - 1
    
    ColorValue = &HFFFFFF And ARGBData((x + 1) + y * Width)
    
    If IsForCell Then
        ColorValue = RGB(Fix(ColorValue / 65536), Fix(ColorValue / 256) Mod 256, ColorValue Mod 256)
    End If
    
    GetPixelColorValue = ColorValue
End Function

Function GetPixelRGB(ARGBData As Object, x As Long, y As Long, Width As Long, Height As Long, ByRef Red As Long, ByRef Green As Long, ByRef Blue As Long) As Boolean
    Dim ColorValue As Long
    
'    If x < 0 Or Width <= x Or y < 0 Or Height <= y Then
'        GetPixelRGB = False
'        Exit Function
'    End If

    If x < 0 Then x = 0 Else: If Width <= x Then x = Width - 1
    If y < 0 Then y = 0 Else: If Height <= y Then y = Height - 1
    
    ColorValue = &HFFFFFF And ARGBData((x + 1) + y * Width)
    
    Red = Fix(ColorValue / 65536)
    Green = Fix(ColorValue / 256) Mod 256
    Blue = ColorValue Mod 256
    
    GetPixelRGB = True
End Function


Sub SetCellSize(WidthPixels As Long, Optional HeightPixels As Long = 0, Optional TargetRange As Range, Optional PixelsToPoints As Double = 0.75)
    If HeightPixels < 1 Then HeightPixels = WidthPixels
    If TargetRange Is Nothing Then Set TargetRange = ActiveSheet.Cells
    
    Dim RefCell As Range: Set RefCell = TargetRange(1, 1)
    Dim WidthOffsetPoints As Double
    Dim CharWidthPoints As Double
    Dim Width1 As Double
    Dim Width2 As Double
    Dim TargetWidthPoints As Double
    Dim SetColumnWidth As Double
    
    RefCell.ColumnWidth = 1: Width1 = RefCell.Width
    RefCell.ColumnWidth = 2: Width2 = RefCell.Width
    CharWidthPoints = Width2 - Width1
    WidthOffsetPoints = Width1 - CharWidthPoints
    
    TargetWidthPoints = WidthPixels * PixelsToPoints
    For SetColumnWidth = (TargetWidthPoints - WidthOffsetPoints) / CharWidthPoints To TargetWidthPoints / CharWidthPoints Step 0.05
        If 0 < SetColumnWidth Then
            RefCell.ColumnWidth = SetColumnWidth
            If TargetWidthPoints <= RefCell.Width Then Exit For
        End If
    Next
    
    TargetRange.ColumnWidth = SetColumnWidth
    TargetRange.RowHeight = HeightPixels * PixelsToPoints
End Sub

Function GetClipboard() As Object
    Set GetClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
End Function

Function GetTextBox() As Object
    Set GetTextBox = CreateObject("Forms.TextBox.1")
End Function

Function GetCssColorCode(Red As Long, Green As Long, Blue As Long, Optional IsRGBFormat As Boolean = False) As String
    If IsRGBFormat Then
        GetCssColorCode = "rgb(" & Red & ", " & Green & ", " & Blue & ")"
    Else
        GetCssColorCode = "#" & Right("0" & Hex(Red), 2) & Right("0" & Hex(Green), 2) & Right("0" & Hex(Blue), 2)
    End If
End Function


Function GetCssColorCodeFromCellColor(CellColorValue As Long, Optional IsRGBFormat As Boolean = False) As String
    Dim Red As Long: Red = CellColorValue Mod 256
    Dim Green As Long: Green = Fix(CellColorValue / 256) Mod 256
    Dim Blue As Long: Blue = Fix(CellColorValue / 65536)
    
    GetCssColorCodeFromCellColor = GetCssColorCode(Red, Green, Blue, IsRGBFormat)
End Function

Mod_ExtractImageToCellsTrial.vba

Option Explicit

' ■ 比較用： ExtractImageToCellsTrial()
' ※ Range.Interior.Color に逐次セットせず、style付のHTMLを作成してクリップボード経由で一度に貼付

Function ExtractImageToCellsTrial(ImageFileName As String, Optional TargetRange As Range, Optional CellWidthPixels As Long = 1, Optional RowLimit As Long = 0, Optional ColumnLimit As Long = 0, Optional PixelsPerSideOfCell As Long = 0, Optional PixelsToPoints As Double = 0.75) As Range
    Dim WIA As Object: Set WIA = GetWIA(ImageFileName)
    Dim ImageWidth As Long: ImageWidth = WIA.Width
    Dim ImageHeight As Long: ImageHeight = WIA.Height
    Dim ARGBData As Object: Set ARGBData = WIA.ARGBData
    
    If PixelsPerSideOfCell < 1 Then
        ' PixelsPerSideOfCell（各セルの辺に対応するピクセル数）が未指定(0)の場合、列数と行数の制限を元にして自動計算
        Dim CalcPixelsHorizontal As Double: CalcPixelsHorizontal = 1
        Dim CalcPixelsVertical As Double: CalcPixelsVertical = 1
        
        If 0 < ColumnLimit And ColumnLimit < ImageWidth Then
            CalcPixelsHorizontal = ImageWidth / ColumnLimit
        End If
        
        If 0 < RowLimit And RowLimit < ImageHeight Then
            CalcPixelsVertical = ImageHeight / RowLimit
        End If
        
        If CalcPixelsHorizontal < CalcPixelsVertical Then CalcPixelsHorizontal = CalcPixelsVertical
        
        PixelsPerSideOfCell = IIf(CalcPixelsHorizontal - Fix(CalcPixelsHorizontal) = 0, Fix(CalcPixelsHorizontal), Fix(CalcPixelsHorizontal) + 1)
        If PixelsPerSideOfCell < 1 Then PixelsPerSideOfCell = 1
    End If
    
    Dim CurrentRow As Long
    Dim CurrentColumn As Long
    Dim RowMax As Long: RowMax = Fix(ImageHeight / PixelsPerSideOfCell)
    Dim ColumnMax As Long: ColumnMax = Fix(ImageWidth / PixelsPerSideOfCell)
    Dim PixelsPerCell As Long: PixelsPerCell = PixelsPerSideOfCell * PixelsPerSideOfCell
    Dim ImageX As Long, ImageY As Long
    Dim OffsetX As Long, OffsetY As Long
    Dim Red As Long, Green As Long, Blue As Long
    Dim RedSum As Long, GreenSum As Long, BlueSum As Long
    Dim CurrentColorValue As Long
    
    If TargetRange Is Nothing Then Set TargetRange = ActiveWindow.ActiveCell
    
    If 0 < RowLimit And RowLimit < RowMax Then RowMax = RowLimit
    If 0 < ColumnLimit And ColumnLimit < ColumnMax Then ColumnMax = ColumnLimit
    
    Set TargetRange = TargetRange(1, 1).Resize(RowMax, ColumnMax)
    
    Call SetCellSize(CellWidthPixels, TargetRange:=TargetRange, PixelsToPoints:=PixelsToPoints)
    
    Dim HTMLChunkIndex As Long
    Dim HTMLChunks() As String
    Dim CssColorCode As String
    
    ReDim HTMLChunks(1 To ColumnMax * RowMax + 2 * RowMax + 2)
    
    HTMLChunkIndex = 1
    HTMLChunks(HTMLChunkIndex) = "<table>": HTMLChunkIndex = HTMLChunkIndex + 1
    
    For CurrentRow = 1 To RowMax
        HTMLChunks(HTMLChunkIndex) = "<tr>": HTMLChunkIndex = HTMLChunkIndex + 1
        For CurrentColumn = 1 To ColumnMax
            ImageX = (CurrentColumn - 1) * PixelsPerSideOfCell
            ImageY = (CurrentRow - 1) * PixelsPerSideOfCell
            RedSum = 0: GreenSum = 0: BlueSum = 0
            For OffsetY = 0 To PixelsPerSideOfCell - 1
                For OffsetX = 0 To PixelsPerSideOfCell - 1
                    Call GetPixelRGB(ARGBData, ImageX + OffsetX, ImageY + OffsetY, ImageWidth, ImageHeight, Red, Green, Blue)
                    RedSum = RedSum + Red: GreenSum = GreenSum + Green: BlueSum = BlueSum + Blue
                Next OffsetX
            Next OffsetY
            CssColorCode = GetCssColorCode(RedSum / PixelsPerCell, GreenSum / PixelsPerCell, BlueSum / PixelsPerCell)
            HTMLChunks(HTMLChunkIndex) = "<td bgcolor=""" & CssColorCode & """></td>": HTMLChunkIndex = HTMLChunkIndex + 1
        Next CurrentColumn
        HTMLChunks(HTMLChunkIndex) = "</tr>": HTMLChunkIndex = HTMLChunkIndex + 1
        If GetInputState() Then DoEvents
    Next CurrentRow
    
    HTMLChunks(HTMLChunkIndex) = "</table>": HTMLChunkIndex = HTMLChunkIndex + 1
    'Debug.Print Join(HTMLChunks, vbCrLf)
   
    ' TODO: クリップボードのコピーとペーストが時々失敗する
    ' ※ GetClipboard() でも GetTextBox() のどちらでも、あまり変わらない
   
    With GetClipboard()
        .SetText Join(HTMLChunks, "")
        .PutInClipboard
    End With
    
'    With GetTextBox()
'        '.MultiLine = True
'        .Text = Join(HTMLChunks, "")
'        .SelStart = 0
'        .SelLength = .TextLength
'        .Copy
'    End With
    
    TargetRange.PasteSpecial Paste:=xlPasteAll
    ' ※ xlPasteAll以外（xlPasteFormats等）はエラーが発生
    
    TargetRange(1, 1).Select

    Set ExtractImageToCellsTrial = TargetRange
End Function

Mod_TestExtractImageToCells.vba

Option Explicit

Sub TestExtractImageToCells(FuncName As String)
    Const CellWidthPixels = 5 ' 展開後の各セルの幅（px単位）
    Const RowLimit = 200 ' 展開行数の制限
    Const ColumnLimit = 200 '展開列数の制限
    Const PixelsPerSideOfCell = 0 ' 1つのセルの辺に対応する画像のピクセル数（0: 自動計算）
    
    Dim ImageFileName As Variant
    ImageFileName = Application.GetOpenFilename(FileFilter:="画像ファイル,*.bmp;*.jpg;*.jpeg;*.gif;*.png")
    If ImageFileName = False Then
        Exit Sub
    End If
    
    Dim WIA As Object: Set WIA = GetWIA(ImageFileName)
    Dim ImageWidth As Long: ImageWidth = WIA.Width
    Dim ImageHeight As Long: ImageHeight = WIA.Height
    
    ActiveSheet.Cells.Delete
    ActiveSheet.Cells(1, 1).Select
    
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Dim StartTime As Double: StartTime = Timer
    Dim EndTime As Double
    Dim TargetRange As Range: Set TargetRange = ActiveSheet.Range("B2")
    
    'Set TargetRange = Application.Run(FuncName, CStr(ImageFileName), TargetRange, CellWidthPixels, RowLimit, ColumnLimit, PixelsPerSideOfCell)
    ' TODO: [うまく実行されないことがある？](https://twitter.com/KotorinChunChun/status/1246771012152078338)
    
    Select Case FuncName
    Case "ExtractImageToCellsTrial"
        Set TargetRange = ExtractImageToCellsTrial(CStr(ImageFileName), TargetRange:=TargetRange, CellWidthPixels:=CellWidthPixels, RowLimit:=RowLimit, ColumnLimit:=ColumnLimit, PixelsPerSideOfCell:=PixelsPerSideOfCell)
    Case Else
        Set TargetRange = ExtractImageToCells(CStr(ImageFileName), TargetRange:=TargetRange, CellWidthPixels:=CellWidthPixels, RowLimit:=RowLimit, ColumnLimit:=ColumnLimit, PixelsPerSideOfCell:=PixelsPerSideOfCell)
    End Select
    
    TargetRange.Select

    EndTime = Timer
    If EndTime < StartTime Then EndTime = EndTime + 24 * 60 * 60
    Debug.Print FuncName & ": " & Format(EndTime - StartTime, "0.0000") & "秒" & _
        " ※" & CStr(ImageWidth) & "x" & CStr(ImageHeight) & _
        "→" & CStr(TargetRange.Columns.Count) & "x" & CStr(TargetRange.Rows.Count)
    
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Sub TestExtractImageToCellsStandard()
    Call TestExtractImageToCells("ExtractImageToCells")
End Sub

Sub TestExtractImageToCellsTrial()
    Call TestExtractImageToCells("ExtractImageToCellsTrial")
End Sub

■ Range.Interior.Color にセットする場合
ExtractImageToCells: 0.4023秒 ※51x51
ExtractImageToCells: 8.0596秒 ※240x240
ExtractImageToCells: 17.9102秒 ※415x320

■ style付きのHTMLを作り、Range.PasteSpecial で貼り付ける場合
ExtractImageToCellsTrial: 0.4248秒 ※51x51
ExtractImageToCellsTrial: 8.9932秒 ※240x240
ExtractImageToCellsTrial: 26.5498秒 ※415x320

※数が多くなるほど Range.PasteSpecial に時間がかかってしまう模様

色を指定するのに styleの代わりに bgcolor を使うするようにしたら、Range.PasteSpecial が速くなった。

■ Range.Interior.Color にセットする場合
ExtractImageToCells: 0.4609秒 ※51x51
ExtractImageToCells: 6.1719秒 ※240x240
ExtractImageToCells: 13.3789秒 ※415x320

■ bgcolor 付きのHTMLを作り、Range.PasteSpecial で貼り付ける場合
ExtractImageToCellsTrial: 0.2734秒 ※51x51
ExtractImageToCellsTrial: 6.1855秒 ※240x240
ExtractImageToCellsTrial: 14.0723秒 ※415x320

そもそも、WIA（Windows Image Acquisition）を使うのなら、ややこしいことを（Shape→クリップボード経由で画像を取得）しなくても画像データが取得できることに気がついた…。

■ Range.Interior.Color にセットする場合
ExtractImageToCells: 0.1133秒 ※51x51
ExtractImageToCells: 2.3438秒 ※240x240
ExtractImageToCells: 4.9844秒 ※415x320

■ bgcolor 付きのHTMLを作り、Range.PasteSpecial で貼り付ける場合
ExtractImageToCellsTrial: 0.1055秒 ※51x51
ExtractImageToCellsTrial: 4.2266秒 ※240x240
ExtractImageToCellsTrial: 6.2676秒 ※415x320

おかげで、Range.PasteSpecial で時間がかかっていることが顕著になった。

モジュールを分割しました。

• 共通：Mod_ExtractImageToCells_Common.vba
• 本体：Mod_ExtractImageToCells.vba
• 比較用：Mod_ExtractImageToCellsTrial.vba
• テスト：Mod_TestExtractImageToCells.vba