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


リボンで自作？アイコンを使う／Excelでアイコンを編集

盆休みの課題として、勤務先で使っているちょこっとした便利さを提供する自作アドインを リボン版に載せ替えてみようと思い立ちました。
しかし、途中で寄り道して自作アイコンの作成～センスに絶望して、エクセルの既存アイコンの改造～エクセルを使ったアイコン作成ツールの作成と、 得意の本末転倒まっしぐらなのでした。
Microsoftから、Office2007IconsGallery.xlsmという、リボンのカスタマイズで使用するアイコンの一覧を表示して、IDが取得出来るツールが提供されています。 これは、開発タブにGallery 1～9のメニューが拡張され、クリックするとアイコン画像のマトリクスが表示され、アイコンをクリックすると、 フォームに画像と、idが表示されるというものです。
この画像(Imageコントロール)をクリックすると、エクセルのワークシートにセル着色として書き出す様に改造しました。
Excel上で改変したのち、PNG形式でファイルに書き出して、Office Ribbon Editor等に取り込んで使用します。
「GDI+」の項に載せてある、画像をセルに取込、セルを画像に書き出すコードの応用編です。 


	
'☆ControlInfoFormモジュールに追加(Image2も同様）
Private Sub Image1_Click()
  setCellColor Image1.Picture
End Sub
	
'☆標準モジュール	
	
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

Public Enum GDIPlusStatusConstants
    Ok = 0
    GenericError = 1
    InvalidParameter = 2
    OutOfMemory = 3
    ObjectBusy = 4
    InsufficientBuffer = 5
    NotImplemented = 6
    Win32Error = 7
    WrongState = 8
    Aborted = 9
    FileNotFound = 10
    ValueOverflow = 11
    AccessDenied = 12
    UnknownImageFormat = 13
    FontFamilyNotFound = 14
    FontStyleNotFound = 15
    NotTrueTypeFont = 16
    UnsupportedGdiplusVersion = 17
    GdiplusNotInitialized = 18
    PropertyNotFound = 19
    PropertyNotSupported = 20
    ProfileNotFound = 21
End Enum

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
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" _
    (ByVal hbm As Long, ByVal hpal As Long, ByRef bitmap As Long) As GDIPlusStatusConstants

Const PixelFormat32bppARGB = &H26200A

'Pictureオブジェクトを渡して、セル着色に変換してワークシートに書き出す
Sub setCellColor(ByVal PicObj As IPictureDisp)
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim lngResult As Long
    Dim lngGDIPToken As Long
    Dim pSrcBitmap As Long
    Dim udtGdiPlus As GdiplusStartupInput
    
    Dim x As Long, y As Long
    Dim myARGB As Long
    Dim strARGB As String
    Dim strBGR As String
    
    'エクセルのセルをpngで書き出すワークブックのシートに出力する
    Const destWbkName As String = "ExcelDeIcon.xlsm"

    If Not openBookCheck(destWbkName) Then
      MsgBox destWbkName & "が開いていません"
      Exit Sub
    End If

'(1) GDI+を使う準備をする
    udtGdiPlus.GdiplusVersion = 1
    If GdiplusStartup(lngGDIPToken, udtGdiPlus, 0&) <> 0 Then
        Exit Sub
    End If
'(2) UserFormのImageのPictureプロパティからbitmapオブジェクトに変換する
    lngResult = GdipCreateBitmapFromHBITMAP(PicObj.Handle, 0&, pSrcBitmap)

'(3)　読み込んだ画像のサイズを取得
    GdipGetImageWidth pSrcBitmap, lngWidth
    GdipGetImageHeight pSrcBitmap, lngHeight
    
'(4)　bitmapオブジェクトから1画素ずつ読み込んで、エクセルのセルのColorに設定
'GDI+から取得する色は透明度を含むARGBであるが、セルに設定する場合はBGRに変換する必要がある
    Application.ScreenUpdating = False
    
'   ExcelDeIconのワークブックのCell(1)から書き出す
    Workbooks(destWbkName).Activate
    ActiveWorkbook.Sheets(1).Activate
    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
    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

'指定したブックが開いているかチェックする関数、開いていればtrue
Private Function openBookCheck(bookName As String) As Boolean
    Dim wb As Workbook
    
    openBookCheck = False
    For Each wb In Workbooks
        If wb.Name = bookName Then openBookCheck = True
    Next wb
End Function

'☆おまけ
Office2007IconsGallery.xlsmをxl2010で開くとUI XMLにエラーがあるというメッセージが表示されます。
下記をコメントアウトすると、出なくなります。
<!-- item id="JapanesePostcardDialog" imageMso="JapanesePostcardDialog" label="JapanesePostcardDialog"/>
					<item id="JotInkStyle1" imageMso="JotInkStyle1" label="JotInkStyle1"/ -->

'☆おまけ2
'セルの着色をpngとして出力します。無着色は透過色とします。
'フォームツールのオプションボタンをセルにリンクさせて、16x16または32x32を切り替えます。
	
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 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 outputCellColor()
    Dim strInName As String
    Dim strOutName As String
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim lngResult As Long
    Dim lngGDIPToken As Long
    Dim pSrcBitmap As Long
    Dim pDstBitmap As Long
    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 optionLinkCell As String = "AL23"

    ChDir GetDesktopPath
    strOutName = getFileName

'(1) GDI+を使う準備をする
    udtGdiPlus.GdiplusVersion = 1
    If GdiplusStartup(lngGDIPToken, udtGdiPlus, 0&) <> 0 Then
        Exit Sub
    End If
    
'(2)　設定したセルの色を逆に画像ファイルに書き出し
    'オプションボタン（フォームコントロールツール）で書き出し画素数を設定
    'セルにリンクさせてある。
    Select Case ActiveSheet.Range(optionLinkCell).Value
      Case 1 '16pixels
        lngWidth = 16
        lngHeight = 16
      Case 2 '32pixels
        lngWidth = 32
        lngHeight = 32
    End Select
'    設定したサイズの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)
        
        'セルに色が無いとき透過色にしてみる
        'セルに色を塗ってあるか否かの判断は.Colorでは出来ないらしい
        If ActiveSheet.Cells(y + 1, x + 1).Interior.ColorIndex = xlNone Then
          myARGB = CLng("&H00000000")
        Else
          'セル色を文字列に変換するが、規定のバイト数を保持しないと、色が化けてしまう
          strBGR = Right("000000" & strBGR, 6)
          myARGB = CLng("&H" & "FF" & Mid(strBGR, 5, 2) & Mid(strBGR, 3, 2) & Mid(strBGR, 1, 2))
        End If
        'セル色をARGBに変換して、オンメモリの画像に設定
        GdipBitmapSetPixel pDstBitmap, x, y, myARGB
      Next x
    Next y
    
    Call GdipSaveImageToFile(pDstBitmap, StrPtr(strOutName), GetCLSID(CLSID_PNG), 0)
    MsgBox "処理終了しました"
    
    Application.ScreenUpdating = True
    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


'AlternativeなZoom操作
Sub altZoom()
  Static currentZoom As Double
  Const minimumZoom As Double = 20
   
  Debug.Print currentZoom
  If ActiveWindow.zoom <= minimumZoom Then
    ActiveWindow.zoom = currentZoom
  Else
    currentZoom = ActiveWindow.zoom
    ActiveWindow.zoom = minimumZoom
  End If
  ActiveSheet.Cells(1).Activate
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

'ダイアログからファイルのフルパス取得
Private Function getFileName() As String
    Dim strFileFilter As String
    Const formTitle As String = "作成もしくは追記するファイル名"
    '戻り値はvariantでないと、escの時エラーとなる
    Dim fname As Variant
    
    '「ファイルを開く」ダイアログを表示
    strFileFilter = "PNG (*.png),*.png"

    Do
        fname = Application.GetSaveAsFilename(FileFilter:=strFileFilter, Title:=formTitle)
    Loop Until fname <> False
    getFileName = fname
End Function