GDIplusCODE


Sub convertImageToCell()
    Dim clGdip As clGDIplus
    Dim retBool As Boolean
    ' ピクセル色成分を受け取る配列
    Dim lPixels() As Byte
    Dim lCptX As Long, lCptY As Long
    Dim colorRed As Long, colorGreen As Long, colorBlue As Long
    Dim dic As Object
    Dim myKey As String
    Dim colorCounter As Long
    Dim OpenFileName As Variant
    Dim srcfile As String
    
    OpenFileName = Application.GetOpenFilename("画像ファイル,*.jpg;*.bmp;*.png")
    If OpenFileName <> False Then
        srcfile = OpenFileName
    Else
        Exit Sub
    End If
    ActiveSheet.Cells.Clear
    Application.ScreenUpdating = False
    Set clGdip = New clGDIplus
    Set dic = CreateObject("Scripting.Dictionary")
    ' 新しいファイルを開く
    retBool = clGdip.OpenFile(srcfile)
    lPixels = clGdip.GetPixels
    For lCptX = 1 To UBound(lPixels(), 2)
        For lCptY = 1 To UBound(lPixels(), 3)
             colorBlue = lPixels(1, lCptX, lCptY)
             colorGreen = lPixels(2, lCptX, lCptY)
             colorRed = lPixels(3, lCptX, lCptY)
             '色成分 不透明度 = lPixels(4, lCptX, lCptY) '無視
            myKey = CStr(colorRed) & "☆" & CStr(colorGreen) & "☆" & CStr(colorBlue)
            If Not dic.exists(myKey) Then
                colorCounter = colorCounter + 1
                'dictionaryを使って56色以下に抑える
                If colorCounter <= 56 Then
                    dic.Add myKey, colorCounter
                    ActiveWorkbook.Colors(colorCounter) = RGB(colorRed, colorGreen, colorBlue)
                End If
            End If
            Cells(lCptY, lCptX).Interior.ColorIndex = dic.item(myKey)
        Next lCptY
    Next lCptX
    Set dic = Nothing
    Set clGdip = Nothing
    Application.ScreenUpdating = True
End Sub

'http://pygj.cocolog-nifty.com/mukago/excel_vba/index.htmlをお借りしています
Private Function getIndexColor(myColorIndex As Long) As myRGB
    Dim ColorHex As String 'Colorプロパティの値を16進数で格納
    Dim j

    ColorHex = Hex(ActiveWorkbook.Colors(myColorIndex))
    For j = 0 To 5 - Len(ColorHex)
        ColorHex = "0" & ColorHex
    Next
    With getIndexColor
    .blue = CLng("&H" & Left(ColorHex, 2))
    .green = CLng("&H" & Right(Left(ColorHex, 4), 2))
    .red = CLng("&H" & Right(ColorHex, 2))
    End With
End Function
画像をセルに読込 56色対応
