VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています（切り貼りとも言います）。
  1. ホーム
  2. GDI+
  3. 8bit_indexed


256色（8bitIndexed)画像を扱う

今の時代に256色画像を扱うニーズは無い様な気がしていたが、QAサイトでお題が出たため、SetPixel & GetPixelに比べて速いといわれるLockBitsの勉強をかねて取り組んでみました
速度に不満を抱くほど、高尚な画像処理をした事も無いんですけどね．．．
1.Pixcelのカラーコードを取得、書き換えてみる
2.PaletteをExcelのシートに取得し、編集して設定してみる。（簡易パレットエディタ）
3.追加：256色のBMPを作成、パレットも設定する。


'参考サイト
'MSDN GDI+ Flat API お馴染みclGDIPlusでも使用していないAPIが載っている（当たり前か）
'http://msdn.microsoft.com/en-us/library/ms533969(v=vs.85).aspx

'VB6/VBAでのAPI宣言例を含む。clGDIPlusで使っていないものもあり。
'https://github.com/javiercrowsoft/cairo-vb6/blob/master/CSChart/GDI%2B/Codigo2/GpGDIPlus/Module/modGDIPlus.bas

Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipLoadImageFromFile Lib "gdiplus.dll" (ByVal mFilename As Long, ByRef mImage As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token 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 GdipGetImagePalette Lib "gdiplus" (ByVal Image As Long, palette As ColorPalette, ByVal size As Long) As Long 'GpStatus
Private Declare Function GdipSetImagePalette Lib "gdiplus" (ByVal Image As Long, palette As ColorPalette) As Long 'GpStatus
Private Declare Function GdipGetImagePaletteSize Lib "gdiplus" (ByVal Image As Long, size As Long) As Long 'GpStatus
Declare Function GdipGetImagePixelFormat Lib "gdiplus" (ByVal Image As Long, PixelFormat As Long) As Long
Private Declare Function GdipGetImageDimension Lib "gdiplus" _
                                               (ByVal Image As Long, ByRef Width As Single, _
                                                ByRef Height As Single) As Long
Private Declare Function GdipBitmapLockBits Lib "gdiplus" (ByVal bitmap As Long, RECT As RECT, ByVal flags As Long, ByVal PixelFormat As Long, lockedBitmapData As BitmapData) As Long
Private Declare Function GdipBitmapUnlockBits Lib "gdiplus" (ByVal bitmap As Long, lockedBitmapData As BitmapData) 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


Public Declare Sub MoveMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Dest As Any, Source As Any, ByVal length As Long)

Private Type GdiplusStartupInput
    GdiplusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type

Private Type UUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type

Private Type ColorPalette
    flags As Long
    count As Long
    Entries(0 To 255) As Long
End Type

Private Type BitmapData
    Width As Long
    Height As Long
    stride As Long
    PixelFormat As Long
    scan0 As Long
    Reserved As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Enum ImageLockMode
  eRead = &H1
  eWrite = &H2
  ReadWrite = &H3
'   ImageLockModeeUserInputBuf = &H4
End Enum

Private Const PixelFormat1bppIndexed = &H30101
Private Const PixelFormat4bppIndexed = &H30402
Private Const PixelFormat8bppIndexed = &H30803
Private Const PixelFormat16bppGreyScale = &H101004
Private Const PixelFormat16bppRGB555 = &H21005
Private Const PixelFormat16bppRGB565 = &H21006
Private Const PixelFormat16bppARGB1555 = &H61007
Private Const PixelFormat24bppRGB = &H21808
Private Const PixelFormat32bppRGB = &H22009
Private Const PixelFormat32bppARGB = &H26200A
Private Const PixelFormat32bppPARGB = &HE200B
Private Const PixelFormat48bppRGB = &H10300C
Private Const PixelFormat64bppARGB = &H34400D
Private Const PixelFormat64bppPARGB = &H1C400E

'新規に256色のビットマップを作成してみる－簡便のためBMPで保存しているが、本来TIFで保存したいというお題だった。
Sub make8bitIndexedBitmap()
  Dim GDIsi As GdiplusStartupInput, gToken As Long, pBitmap As Long
  Dim bmpData As BitmapData
  Dim lrect As RECT
  Dim x As Long, y As Long
  Dim lWidth As Single, lHeight As Single
  Dim buf(0) As Byte
  Dim strOutName As String
  Dim encBMP As UUID
  Dim paletteSize As Long
  Dim palette As ColorPalette
  Dim i As Long
  Dim myARGB As Long
  
  On Error Resume Next
  GDIsi.GdiplusVersion = 1&
  GdiplusStartup gToken, GDIsi
  
  lWidth = 16: lHeight = 16
  Call GdipCreateBitmapFromScan0(lWidth, lHeight, 0, PixelFormat8bppIndexed, ByVal 0&, pBitmap)
  
  lrect.Top = 0: lrect.Left = 0
  lrect.Bottom = CLng(lHeight): lrect.Right = CLng(lWidth)

  If GdipBitmapLockBits(pBitmap, lrect, ImageLockMode.ReadWrite, PixelFormat8bppIndexed, bmpData) <> 0 Then
    Exit Sub
  End If

  i = 0
    For y = 0 To lHeight - 1
      For x = 0 To lWidth - 1
        buf(0) = i
        MoveMemory ByVal bmpData.scan0 + (y * bmpData.stride) + x, buf(0), 1
        i = i + 1
      Next x
    Next y
  Call GdipBitmapUnlockBits(pBitmap, bmpData)
  Call GdipGetImagePaletteSize(pBitmap, paletteSize)
  Call GdipGetImagePalette(pBitmap, palette, paletteSize)
  For i = 0 To 255
    myARGB = ARGB(255, CByte(i), CByte(i), CByte(i))
    palette.Entries(i) = myARGB
  Next i
  Call GdipSetImagePalette(pBitmap, palette)
  strOutName = GetDesktopPath & "\make8bitIndexed.bmp"
  CLSIDFromString StrPtr("{557CF400-1A04-11D3-9A73-0000F81EF32E}"), encBMP
  Call GdipSaveImageToFile(pBitmap, StrPtr(strOutName), encBMP, ByVal 0&)

  GdipDisposeImage pBitmap
  GdiplusShutdown gToken
End Sub

Private Function ARGB(Alpha As Byte, Red As Byte, Green As Byte, Blue As Byte) As Long
    If Alpha > 127 Then
       ARGB = ((Alpha - 128) * &H1000000 Or &H80000000) Or _
            Red Or (Green * &H100&) Or (Blue * &H10000)
    Else
       ARGB = (Alpha * &H1000000) Or _
            Red Or (Green * &H100&) Or (Blue * &H10000)
    End If
End Function

'指定ピクセルのPalette番号取得、Palette番号書き換え
Sub lockUnlockBit()
  Dim GDIsi As GdiplusStartupInput, gToken As Long, pBitmap As Long
  Dim fileName As String
  Dim bmpData As BitmapData
  Dim lrect As RECT
  Dim x As Long, y As Long
  Dim lWidth As Single, lHeight As Single
  Dim buf(0) As Byte
  Dim strOutName As String
  Dim encBMP As UUID
  Dim PixelFormat As Long
  
  On Error Resume Next
  GDIsi.GdiplusVersion = 1&
  'このコードではGdiplusStartupの第三引数をOptionalでDeclareしてある 
  GdiplusStartup gToken, GDIsi
  If Err Then
        Err.Clear
        Exit Sub
  ElseIf gToken = 0& Then
       Exit Sub
  End If
  On Error GoTo 0
  
  fileName = GetDesktopPath & "\" & "lockbitstest.bmp"
  Call GdipLoadImageFromFile(StrPtr(fileName), pBitmap)
  
  '256色(8bit indexed)の画像でない場合は抜ける
  Call GdipGetImagePixelFormat(pBitmap, PixelFormat)
  If PixelFormat <> PixelFormat8bppIndexed Then Exit Sub
  
  GdipGetImageDimension pBitmap, lWidth, lHeight
  'ここは書き換えに必要なサイズだけでも可だが、とりあえず画像全体をLockBits
  lrect.Top = 0: lrect.Left = 0
  lrect.Bottom = CLng(lHeight): lrect.Right = CLng(lWidth)
  
  If GdipBitmapLockBits(pBitmap, lrect, ImageLockMode.ReadWrite, PixelFormat8bppIndexed, bmpData) <> 0 Then
    Exit Sub
  End If

  '画素1pixelの取得
    x = 10: y = 20
    '変数に指定メモリ番地の値を取得、配列の先頭を用いるのがミソ
    MoveMemory buf(0), ByVal bmpData.scan0 + (y * bmpData.stride) + x, 1
    Debug.Print buf(0)  '249 - 今回の例では
  
  '書き換えてみる
  buf(0) = 252
  For x = 0 To 20
    For y = 0 To 20
      MoveMemory ByVal bmpData.scan0 + (y * bmpData.stride) + x, buf(0), 1
    Next y
  Next x
  
  'BMP保存
  strOutName = GetDesktopPath & "\destLockbitstest.bmp"
  CLSIDFromString StrPtr("{557CF400-1A04-11D3-9A73-0000F81EF32E}"), encBMP
  GdipSaveImageToFile pBitmap, StrPtr(strOutName), encBMP, ByVal 0&

  Call GdipBitmapUnlockBits(pBitmap, bmpData)
  GdipDisposeImage pBitmap
  GdiplusShutdown gToken
End Sub

'Excelのセルの着色をパレットにして画像を別名保存
Sub setPalette()
  Dim GDIsi As GdiplusStartupInput, gToken As Long, pBitmap As Long
  Dim srcFileName As String, destFileName
  Dim paletteSize As Long
  Dim palette As ColorPalette
  Dim i As Long
  Dim strBGR As String
  Dim myARGB As Long
  Dim encBMP As UUID
  Dim PixelFormat As Long
  
  GDIsi.GdiplusVersion = 1&
  GdiplusStartup gToken, GDIsi
  If Err Then
        Err.Clear
        Exit Sub
  ElseIf gToken = 0& Then
       Exit Sub
  End If
  
  srcFileName = GetDesktopPath & "\" & "lockbitstest.bmp"
  destFileName = GetDesktopPath & "\" & "lockbitstest2.bmp"
  
  Call GdipLoadImageFromFile(StrPtr(srcFileName), pBitmap)
  Call GdipGetImagePixelFormat(pBitmap, PixelFormat)
  If PixelFormat <> PixelFormat8bppIndexed Then Exit Sub
  
  Call GdipGetImagePaletteSize(pBitmap, paletteSize)
  Call GdipGetImagePalette(pBitmap, palette, paletteSize)
  'Range("A1:P16")のセルの色からPaletteの色を設定する
  For i = 0 To 255
     strBGR = Hex(ActiveSheet.Cells((i \ 16) + 1, (i Mod 16) + 1).Interior.Color)
    strBGR = Right("000000" & strBGR, 6)
    myARGB = CLng("&H" & "FF" & Mid(strBGR, 5, 2) & Mid(strBGR, 3, 2) & Mid(strBGR, 1, 2))
    palette.Entries(i) = myARGB
  Next i
  Call GdipSetImagePalette(pBitmap, palette)
  'BMP形式で保存
  CLSIDFromString StrPtr("{557CF400-1A04-11D3-9A73-0000F81EF32E}"), encBMP
  GdipSaveImageToFile pBitmap, StrPtr(destFileName), encBMP, ByVal 0&

  GdipDisposeImage pBitmap
  GdiplusShutdown gToken
End Sub

'指定BMPからパレットを取得してExcelのワークシートに表示
Sub getPalette()
  Dim GDIsi As GdiplusStartupInput, gToken As Long, pBitmap As Long
  Dim fileName As String
  Dim paletteSize As Long
  Dim palette As ColorPalette
  Dim mycolor As Long
  Dim i As Long
  Dim strARGB As String
  Dim PixelFormat As Long

  GDIsi.GdiplusVersion = 1&
  GdiplusStartup gToken, GDIsi
  If Err Then
        Err.Clear
        Exit Sub
  ElseIf gToken = 0& Then
       Exit Sub
  End If
  
  fileName = GetDesktopPath & "\" & "lockbitstest.bmp"
  Call GdipLoadImageFromFile(StrPtr(fileName), pBitmap)
  Call GdipGetImagePixelFormat(pBitmap, PixelFormat)
  If PixelFormat <> PixelFormat8bppIndexed Then Exit Sub
  
  Call GdipGetImagePaletteSize(pBitmap, paletteSize)
  Call GdipGetImagePalette(pBitmap, palette, paletteSize)
  'Range("A1:P16")のセルにPaletteの色を着色する
  For i = 0 To 255
    mycolor = palette.Entries(i)
    strARGB = Hex(mycolor)
    Cells((i \ 16) + 1, (i Mod 16) + 1).Interior.Color = RGB(CInt("&H" & Mid(strARGB, 3, 2)), CInt("&H" & Mid(strARGB, 5, 2)), CInt("&H" & Mid(strARGB, 7, 2)))
  Next i

  GdipDisposeImage pBitmap
  GdiplusShutdown gToken
End Sub

Private Function GetDesktopPath() As String
  Dim wScriptHost As Object, strInitDir As String
  Set wScriptHost = CreateObject("Wscript.Shell")
  GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
  Set wScriptHost = Nothing
End Function