none
Excel2007のVBAでリボンのアイコンにファイルから読み込まずに白色のBitmap画像を表示したい。 RRS feed

  • 質問

  • はじめまして、よろしくお願いいたします。
    Web上のサンプルなどを参照したのですが、うまくいかなかったので、質問させてください。

    まず仕様なのですが、
    ①Excel2007のVBAでリボンのアイコンに白色のBitmap画像を表示したい。(VSTOは、持っていません。)
    ②Bitmap画像は、ファイルやフォームに保存してあるBitmap画像を使用するのではなく、メモリ上にBitmap画像を作成して、表示させたい。ワークシート上に保存してある場合は可能。
    →理由は、配布しやすいように、Excelマクロファイル本体のみにしたいため。
    以上のようなのもを作ろうと思っています。

    次に、今回テストしたソースコードを示します。
    (参照したソースコードは、
    ①「初心者備忘録」[http://www.ka-net.org/ribbon/ri27.html]のページ
    ②「Ribbon」[http://homepage2.nifty.com/suyamsoft/Ribbon/]
    ③書籍「Excel VBAによるWin32 API プログラミング入門」/大村あつし著
    を参照させていただきました。)

    このソースコードでは、CreateBitmap関数でメモリ上にBitmap画像を作成して、表示させようとしていますが、画像の色が、白色ではなく、黒色になってしまいます。

    ===============================================================================
    ThisWorkbook
    -------------------------------------------------------------------------------
    Option Explicit
    
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
        
        Call DeleteObject(hBitmap)
        
    End Sub
    
    ===============================================================================
    MainModule
    -------------------------------------------------------------------------------
    Option Explicit
    
    Private Type PICTDESC
        Size As Long
        Type As Long
        hPic As Long
        hPal As Long
    End Type
    
    Private Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type
    
    Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long
    Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
    Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
    Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
    Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, lpiid As Any) As Long
    Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As Long, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits() As Any) As Long
    Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Declare Function SetErrorMode Lib "kernel32" (ByVal wMode As Long) As Long
    Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
    
    Const SEM_FAILCRITICALERRORS = &H1&
    
    Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200&
    Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000&
    
    Const IID_IPictureDisp As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
    
    Public hBitmap As Long
    
    Dim myRibbon As IRibbonUI
    
    Private Function ConvertToIPicture(ByVal hPic As Long, ByVal PICTYPE_TYPE_NUM As Long, ByVal IID_KIND As String) As IPicture
        
        Dim IID(0 To 3) As Long
        Dim IPic As IPicture
        Dim uPicInfo As PICTDESC
        
        With uPicInfo
            .Size = Len(uPicInfo)
            .Type = PICTYPE_TYPE_NUM
            .hPic = hPic
            .hPal = 0&
        End With
        
        Call IIDFromString(StrPtr(IID_KIND), IID(0))
        Call OleCreatePictureIndirect(uPicInfo, IID(0), True, IPic)
        Set ConvertToIPicture = IPic
        
    End Function
    
    Function LoadImage() As IPicture
        
        Dim strBuffer As String * 1024
        Dim rc As Long
        
        Dim uGdiInput As GdiplusStartupInput
        Dim hGdiPlus As Long
        Dim hGdiImage As Long
        Dim PICTYPE_TYPE_NUM As Long
        
        Dim nWidth As Long
        Dim nHeight As Long
        Dim cPlanes As Long
        Dim nBitCount As Long
        Dim lpBits(0) As Byte
        
        ' 1 × 1 のBitmapを指定
        nWidth = 0
        nHeight = 0
        cPlanes = 1
        nBitCount = 1
        
        ' 白色を指定している
        lpBits(0) = &HFF
        
        PICTYPE_TYPE_NUM = 1  ' bit map
        
        'OSによるエラー処理を抑止して呼び出し側のプロセスにエラーを送る
        rc = SetErrorMode(SEM_FAILCRITICALERRORS)
        
        uGdiInput.GdiplusVersion = 1&
        
        If GdiplusStartup(hGdiPlus, uGdiInput) = 0& Then
            hBitmap = CreateBitmap(nWidth, nHeight, cPlanes, nBitCount, lpBits)
            
            'エラーが発生
            rc = FormatMessage(FORMAT_MESSAGE_IGNORE_INSERTS Or _
                                FORMAT_MESSAGE_FROM_SYSTEM, _
                                ByVal vbNullString, _
                                Err.LastDllError, _
                                0&, _
                                strBuffer, _
                                Len(strBuffer), _
                                0&)
            MsgBox _
            Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
            
            MsgBox hBitmap
            Set LoadImage = ConvertToIPicture(hBitmap, PICTYPE_TYPE_NUM, IID_IPictureDisp)
            Call GdipDisposeImage(hGdiImage)
            Call GdiplusShutdown(hGdiPlus)
        End If
        
        'エラーの処理モードを既定に設定
        rc = SetErrorMode(0&)
        
    End Function
    
    Sub OnLoad(ribbon As IRibbonUI)
    	
        Set myRibbon = ribbon
        myRibbon.Invalidate
        
    End Sub
    
    Sub GetImage(control As IRibbonControl, ByRef image)
    
        Dim strBuffer As String * 1024
        Dim rc As Long
        
        'OSによるエラー処理を抑止して呼び出し側のプロセスにエラーを送る
        rc = SetErrorMode(SEM_FAILCRITICALERRORS)
        
        Set image = LoadImage()
        
        'エラーが発生
        rc = FormatMessage(FORMAT_MESSAGE_IGNORE_INSERTS Or _
                            FORMAT_MESSAGE_FROM_SYSTEM, _
                            ByVal vbNullString, _
                            Err.LastDllError, _
                            0&, _
                            strBuffer, _
                            Len(strBuffer), _
                            0&)
        MsgBox _
        Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
        
        'エラーの処理モードを既定に設定
        rc = SetErrorMode(0&)
        
    End Sub
    
    Sub OnAction(control As IRibbonControl)
        MsgBox "OK!"
    End Sub
    
    ===============================================================================
    
    

     

    ===============================================================================
    Ribbon.xml
    -------------------------------------------------------------------------------
    <?xml version="1.0" encoding="UTF-8" standalone="yes"?>
    <customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="OnLoad">
    	<ribbon startFromScratch="false">
    		<tabs>
    			<tab id="customTab" label="Custom Tab" insertBeforeMso="TabHome">
    				<group id="customGroup" label="Custom Group">
    					<button id="myButton" label="My Button" getImage="GetImage" size="large" onAction="OnAction" />
    				</group>
    			</tab>
    		</tabs>
    	</ribbon>
    </customUI>
    
    ===============================================================================
    
    


    以上、大変恐縮ですが、どうかご協力をお願いいたします。


    • 編集済み ごんぞう 2011年10月29日 20:54
    • 移動 山本春海 2011年11月2日 9:09 より適切と思われるカテゴリに移動 (移動元:Visual Studio Tools for Office)
    2011年10月24日 22:45

回答

  • すいません。
    自己解決してしまいました。。。
    CreateBitmap関数がGDI+の関数だと思っていたら、GDIの関数だったことに気づき、GdipCreateBitmapFromGdiDib関数を使用したところ、うまくいきました。
    結果を掲載しておきます。

    ===============================================================================
    MainModule
    -------------------------------------------------------------------------------
    Option Explicit
    
    Private Type PICTDESC
        Size As Long
        Type As Long
        hPic As Long
        hPal As Long
    End Type
    
    Private Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type
    
    Private Type BITMAPINFOHEADER
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
    End Type
    
    Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
    End Type
    
    Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors(1) As RGBQUAD
    End Type
    
    Declare Function GdipCreateBitmapFromGdiDib Lib "GDIPlus" (ByRef gdiBitmapInfo As BITMAPINFO, ByRef gdiBitmapData() As Any, bitmap As Long) As Long
    Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
    Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
    Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
    Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, lpiid As Any) As Long
    Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As Long, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Declare Function SetErrorMode Lib "kernel32" (ByVal wMode As Long) As Long
    Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
    
    Const SEM_FAILCRITICALERRORS = &H1&
    
    Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200&
    Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000&
    
    Const IID_IPictureDisp As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
    Const PICTYPE_BITMAP As Long = 1
    
    Const BI_RGB As Long = 0
    
    Dim myRibbon As IRibbonUI
    
    Function ConvertToIPicture(ByVal hPic As Long) As IPicture
        
        Dim IID(0 To 3) As Long
        Dim IPic As IPicture
        Dim uPicInfo As PICTDESC
        
        With uPicInfo
            .Size = Len(uPicInfo)
            .Type = PICTYPE_BITMAP
            .hPic = hPic
            .hPal = 0&
        End With
        
        Call IIDFromString(StrPtr(IID_IPictureDisp), IID(0))
        Call OleCreatePictureIndirect(uPicInfo, IID(0), True, IPic)
        Set ConvertToIPicture = IPic
        
    End Function
    
    Function LoadWhiteImage() As IPicture
        
        Dim strBuffer As String * 1024
        Dim rc As Long
        
        Dim uGdiInput As GdiplusStartupInput
        Dim hGdiPlus As Long
        Dim hGdiImage As Long
        Dim hBitmap As Long
        
        Dim bmiHeader As BITMAPINFOHEADER
        Dim bmiColors(1) As RGBQUAD
        Dim gdiBitmapInfo As BITMAPINFO
        Dim gdiBitmapData(0) As Byte
        
        'OSによるエラー処理を抑止して呼び出し側のプロセスにエラーを送る
        rc = SetErrorMode(SEM_FAILCRITICALERRORS)
        
        uGdiInput.GdiplusVersion = 1&
        
        ' BITMAPINFOHEADERの設定
        With bmiHeader
            .biSize = Len(bmiHeader)
            .biWidth = 1&
            .biHeight = 1&
            .biPlanes = 1
            .biBitCount = 1
            .biCompression = BI_RGB     ' An uncompressed format.
            .biSizeImage = 0&           ' The size, in bytes, of the image.
                                        ' This may be set to zero for BI_RGB bitmaps.
            .biXPelsPerMeter = 0&       ' Not used
            .biYPelsPerMeter = 0&       ' Not used
            .biClrUsed = 0&             ' The number of color indexes in the color table that are actually used by the bitmap.
                                        ' If this value is zero, the bitmap uses the maximum number of colors corresponding to the value of the biBitCount member for the compression mode specified by biCompression.
            .biClrImportant = 0&        ' The number of color indexes that are required for displaying the bitmap.
                                        ' If this value is zero, all colors are required.
        End With
        
        ' RGBQUADの設定
        With bmiColors(0)
            .rgbBlue = &H0
            .rgbGreen = &H0
            .rgbRed = &H0
            .rgbReserved = 0    ' This member is reserved and must be zero.
        End With
        With bmiColors(1)
            .rgbBlue = &HFF
            .rgbGreen = &HFF
            .rgbRed = &HFF
            .rgbReserved = 0    ' This member is reserved and must be zero.
        End With
        
        ' BITMAPINFOの設定
        With gdiBitmapInfo
            .bmiHeader = bmiHeader
            .bmiColors(0) = bmiColors(0)
            .bmiColors(1) = bmiColors(1)
        End With
        
        ' 白色を指定している
        gdiBitmapData(0) = &HFF
        
        If GdiplusStartup(hGdiPlus, uGdiInput) = 0& Then
            
            If GdipCreateBitmapFromGdiDib(gdiBitmapInfo, gdiBitmapData(), hGdiImage) = 0& Then
                
                Call GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0&)
                Set LoadWhiteImage = ConvertToIPicture(hBitmap)
                Call GdipDisposeImage(hGdiImage)
                
            Else
                
                'エラーが発生
                rc = FormatMessage(FORMAT_MESSAGE_IGNORE_INSERTS Or _
                                    FORMAT_MESSAGE_FROM_SYSTEM, _
                                    ByVal vbNullString, _
                                    Err.LastDllError, _
                                    0&, _
                                    strBuffer, _
                                    Len(strBuffer), _
                                    0&)
                MsgBox Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
                
            End If
            
            Call GdiplusShutdown(hGdiPlus)
            
        Else
            
            'エラーが発生
            rc = FormatMessage(FORMAT_MESSAGE_IGNORE_INSERTS Or _
                                FORMAT_MESSAGE_FROM_SYSTEM, _
                                ByVal vbNullString, _
                                Err.LastDllError, _
                                0&, _
                                strBuffer, _
                                Len(strBuffer), _
                                0&)
            MsgBox Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
            
        End If
        
        'エラーの処理モードを既定に設定
        rc = SetErrorMode(0&)
        
    End Function
    
    Sub OnLoad(ribbon As IRibbonUI) ' リボンの初期処理
        Set myRibbon = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
        myRibbon.Invalidate ' リボンの表示を更新する
    End Sub
    
    Sub GetImage(control As IRibbonControl, ByRef image)
    
        Dim strBuffer As String * 1024
        Dim rc As Long
        
        'OSによるエラー処理を抑止して呼び出し側のプロセスにエラーを送る
        rc = SetErrorMode(SEM_FAILCRITICALERRORS)
        
        Set image = LoadWhiteImage()
        
        'エラーが発生
        rc = FormatMessage(FORMAT_MESSAGE_IGNORE_INSERTS Or _
                            FORMAT_MESSAGE_FROM_SYSTEM, _
                            ByVal vbNullString, _
                            Err.LastDllError, _
                            0&, _
                            strBuffer, _
                            Len(strBuffer), _
                            0&)
        MsgBox Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
        
        'エラーの処理モードを既定に設定
        rc = SetErrorMode(0&)
        
    End Sub
    
    Sub OnAction(control As IRibbonControl)
        MsgBox "OK!"
    End Sub
    
    ===============================================================================
    
    

     

    ===============================================================================
    Ribbon.xml
    -------------------------------------------------------------------------------
    <?xml version="1.0" encoding="UTF-8" standalone="yes"?>
    <customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="OnLoad">
    	<ribbon startFromScratch="false">
    		<tabs>
    			<tab id="customTab" label="Custom Tab" insertBeforeMso="TabHome">
    				<group id="customGroup" label="Custom Group">
    					<button id="myButton" label="My Button" getImage="GetImage" size="large" onAction="OnAction" />
    				</group>
    			</tab>
    		</tabs>
    	</ribbon>
    </customUI>
    
    ===============================================================================
    
    


    以上、ご協力ありがとうございました。

    • 回答としてマーク ごんぞう 2011年11月14日 9:33
    2011年11月14日 9:32