GDIplusCODE


Private Type UUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
    Guid As UUID
    NumberOfValues As Long
    Type As Long
    Value As Long
End Type
Private Type EncoderParameters
    Count As Long
    Parameter(15) As EncoderParameter
End Type

Private Declare Function GdiplusStartup Lib "gdiplus.dll" (ByRef token As Long, ByRef inputBuf As GdiplusStartupInput, ByVal outputBuf As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long)
Private Declare Function GdipDisposeImage Lib "gdiplus.dll" (ByVal image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus.dll" (ByVal image As Long, ByVal fileName As Long, ByRef clsidEncoder As UUID, ByVal encoderParams As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszCLSID As Long, ByRef pclsid As UUID) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (fileName As Any, bitmap As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As Long
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As Long
Private Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, color As Long) As Long
Private Declare Function GdipBitmapSetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, ByVal color As Long) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus.dll" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, nBitmap As Long) As Long

Const PixelFormat32bppARGB = &H26200A

Sub setAndGetCellColor()
    Dim strInName As String
    Dim strOutName As String
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim Quality As Long
    Dim lngResult As Long
    Dim lngGDIPToken As Long
    Dim pSrcBitmap As Long
    Dim pDstBitmap As Long
    Dim udtEncParam As EncoderParameters
    Dim udtGdiPlus As GdiplusStartupInput
    
    Dim x As Long, y As Long
    Dim myARGB As Long
    Dim strARGB As String
    Dim strBGR As String

    Const CLSID_PNG = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
    Const CLSID_JPEG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
    Const CLSID_QUALITY = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

    Quality = 90
    strInName = "C:\Users\hoge\Desktop\test.jpg"
    strOutName = "C:\Users\hoge\Desktop\test.jpg"

'(1) GDI+を使う準備をする
    udtGdiPlus.GdiplusVersion = 1
    If GdiplusStartup(lngGDIPToken, udtGdiPlus, 0&) <> 0 Then
        Exit Sub
    End If
'(2) ファイルから画像を読み込みbitmapオブジェクトに変換する
' bitmapオブジェクトはimageクラスを継承したクラスで、pixel操作ができる
'また、imageを引数とする関数に、同様に引数として渡す事ができる
    If GdipCreateBitmapFromFile(ByVal StrPtr(strInName), pSrcBitmap) <> 0 Then
      Exit Sub
    End If
'(3)　読み込んだ画像のサイズを取得
'画素数は480x360程度でないと、書式が多すぎるというエラーが発生する
    GdipGetImageWidth pSrcBitmap, lngWidth
    GdipGetImageHeight pSrcBitmap, lngHeight
    
'(4)　bitmapオブジェクトから1画素ずつ読み込んで、エクセルのセルのColorに設定
'GDI+から取得する色は透明度を含むARGBであるが、セルに設定する場合はBGRに変換する必要がある
    Application.ScreenUpdating = False
    For y = 0 To lngHeight - 1
      For x = 0 To lngWidth - 1
        '画素の色を取り出し、文字列に変換する
        'ビットシフトは面倒そうなので、スピードは犠牲にして？文字列に変換して処理
        GdipBitmapGetPixel pSrcBitmap, x, y, myARGB
        strARGB = Hex(myARGB&)
        With ActiveSheet
          Range(.Cells(1, 1), .Cells(1, lngWidth)).ColumnWidth = 1.63
          'ARGB->BGRに変換してセル色に変換
          .Cells(y + 1, x + 1).Interior.color = RGB(CInt("&H" & Mid(strARGB, 3, 2)), CInt("&H" & Mid(strARGB, 5, 2)), CInt("&H" & Mid(strARGB, 7, 2)))
        End With
      Next x
    Next y
    Application.ScreenUpdating = True
    
'(5)　設定したセルの色を逆に画像ファイルに書き出し
    'メモリ上に読み込んだ画像と同じサイズのbitmapオブジェクトを生成
    lngResult = GdipCreateBitmapFromScan0(lngWidth, lngHeight, 0, PixelFormat32bppARGB, ByVal 0&, pDstBitmap)
    
    For y = 0 To lngHeight - 1
      For x = 0 To lngWidth - 1
        strBGR = Hex(ActiveSheet.Cells(y + 1, x + 1).Interior.color)
        'セル色を文字列に変換するが、規定のバイト数を保持しないと、色が化けてしまう
        strBGR = Right("000000" & strBGR, 6)
        myARGB = CLng("&H" & "FF" & Mid(strBGR, 5, 2) & Mid(strBGR, 3, 2) & Mid(strBGR, 1, 2))
        'セル色をARGBに変換して、オンメモリの画像に設定
        GdipBitmapSetPixel pDstBitmap, x, y, myARGB
      Next x
    Next y
    
    ' JPG変換で保存
    udtEncParam.Count = 1
    With udtEncParam.Parameter(0)
        .Guid = GetCLSID(CLSID_QUALITY)
        .NumberOfValues = 1
        .Type = 4
        .Value = VarPtr(Quality)
    End With
    Call GdipSaveImageToFile(pDstBitmap, StrPtr(strOutName), GetCLSID(CLSID_JPEG), VarPtr(udtEncParam))
    GdipDisposeImage pDstBitmap
    GdipDisposeImage pSrcBitmap
    Call GdiplusShutdown(lngGDIPToken)
End Sub

Private Function GetCLSID(ByVal strGuid As String) As UUID
Dim lngResult As Long
    lngResult = CLSIDFromString(StrPtr(strGuid), GetCLSID)
End Function

☆おまけ　ARGBと、BGRの相互変換（αチャンネルFFの場合）
その後文字列を扱わない方法を試してみたが、セルアクセスの速度が支配的らしく画期的に速くなったとは思えなかった

ARGB→BGR
myColor = myARGB And &HFFFFFF
newColor = (myColor And &HFF&) * &H10000 Or _
           ((myColor \ &H100&) And &HFF&) * &H100& Or _
           ((myColor \ &H10000) And &HFF&)
BGR→ARGB                
myColor = ActiveSheet.Cells(y + 1, x + 1).Interior.color
newColor = (myColor And &HFF&) * &H10000 Or _
            ((myColor \ &H100&) And &HFF&) * &H100& Or _
            ((myColor \ &H10000) And &HFF&)
myARGB = &HFF000000 Or newColor

αチャンネルが設定してある場合は、VBAでは符号なし整数が使えない事から、Aが127以上か未満かで処理を変えるといった
面倒があるらしい
http://www.vbforums.com/showthread.php?553463-How-to-convert-RGB-to-ARGB
画像→セル色に変換、セル色→画像に変換
