GDIplusCODE


Type myRGB
    red As Long
    green As Long
    blue As Long
End Type

'画像をセルに読込：フルカラー対応に改造
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 OpenFileName As Variant
    Dim srcfile As String
    
    'ここも2000対応だが動く
    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
    ' 新しいファイルを開く
    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) '無視
            Cells(lCptY, lCptX).Interior.Color = RGB(colorRed, colorGreen, colorBlue)
        Next lCptY
    Next lCptX
    Set clGdip = Nothing
    Application.ScreenUpdating = True
End Sub

'選択範囲のセルを画像に書き出し
Sub convertCellToImage()
    Dim clGdip As clgdiplus
    Dim retBool As Boolean
    ' ピクセル色成分を受け取る配列
    Dim lPixels() As Byte
    ' カウンタ
    Dim lCptX As Long, lCptY As Long
    Dim xoffset As Long, yoffset As Long
    Dim myCellColor As myRGB
    Dim destfile As String
    Dim ImageWidth As Long, ImageHeight As Long
    Dim vntFileName As Variant
    Dim pictType As String
    Const jpegQuality As Long = 90
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    ImageWidth = Selection.Columns.count
    ImageHeight = Selection.Rows.count
    xoffset = Selection.Cells(1).Column - 1
    yoffset = Selection.Cells(1).Row - 1
    'ファイルを保存するダイアログを開きます
    vntFileName = _
        Application.GetSaveAsFilename(InitialFileName:="picture.jpg" _
           , FileFilter:="画像ファイル,*.jpg;*.bmp;*.png" _
           , FilterIndex:=1 _
           , Title:="保存先の指定" _
           )
    If vntFileName <> False Then
        Select Case StrConv(Right(vntFileName, 3), vbUpperCase)
        Case "JPG"
            pictType = "JPG"
        Case "BMP"
            pictType = "BMP"
        Case "PNG"
            pictType = "PNG"
        Case Else
            MsgBox "サポートされていない画像形式です"
            Exit Sub
        End Select
        destfile = vntFileName
    Else
        Exit Sub
    End If

    Set clGdip = New clgdiplus
    ' 新しいビットマップを作成 幅、高さ、解像度（デフォルト96)
    retBool = clGdip.CreateBitmap(ImageWidth, ImageHeight, 96)
    ' ピクセル色成分を配列に設定
    lPixels = clGdip.GetPixels
    ' ピクセル単位でループ
    For lCptX = 1 To UBound(lPixels(), 2)
        For lCptY = 1 To UBound(lPixels(), 3)
            myCellColor = getColor(Cells(lCptY + yoffset, lCptX + xoffset).Interior.Color)
            With myCellColor
                lPixels(1, lCptX, lCptY) = .blue
                lPixels(2, lCptX, lCptY) = .green
                lPixels(3, lCptX, lCptY) = .red
                lPixels(4, lCptX, lCptY) = &HFF
            End With
        Next lCptY
    Next lCptX
'    ' 画像の色成分を設定
    clGdip.SetPixels lPixels
    If pictType = "JPG" Then
        retBool = clGdip.SaveFile(destfile, "JPG", jpegQuality)
    Else
        retBool = clGdip.SaveFile(destfile, pictType)
    End If
    Set clGdip = Nothing
End Sub

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

    ColorHex = Hex(myColor)
    For j = 0 To 5 - Len(ColorHex)
        ColorHex = "0" & ColorHex
    Next
    With getColor
    .blue = CLng("&H" & Left(ColorHex, 2))
    .green = CLng("&H" & Right(Left(ColorHex, 4), 2))
    .red = CLng("&H" & Right(ColorHex, 2))
    End With
End Function

'おまけ：セル幅を18pixelに調整するコード
'試しに全列対象に実行してみたら、気が遠くなるほど（大げさ）時間がかかりました。
Private Sub setColumnWidth()
    Dim i As Long
    
    Application.ScreenUpdating = False
    For i = 1 To 1000
        Columns(i).ColumnWidth = 1.63
    Next i
    Application.ScreenUpdating = True
End Sub
画像←→セル変換フルカラー版
