HOME > エクセルVBA > サンプル > LoadPng

LoadPng


【ファイル名】LoadPng.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年05月11日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】LoadPng.zip
【説明】PNGのファイルを読み込み、ボタンの画像を変更するサンプルです。
メニュー

ボタンをクリックすると交互に画像を変更します。

【外部リンク】初心者備忘録 > リボン関連 > ボタンのイメージを外部から読み込む(PNG対応版)
【外部リンク】Windows > Apps > Win32 > API > Component Object Model (COM) > Olectl.h >  OleCreatePictureIndirect
【外部リンク】Windows > Apps > Win32 > API > GDI+ > Gdiplusinit.h > GdiplusStartupInput structure
【外部リンク】Windows > Apps > Win32 > デスクトップテクノロジ > グラフィックスとゲーミング > GDI+ >  ビットマップ関数 (GDI +)
【外部リンク】Windows > Apps > Win32 > デスクトップテクノロジ > グラフィックスとゲーミング > GDI+ >  イメージ関数
【外部リンク】Windows > Apps > Win32 > API > GDI+ > Gdiplusinit.h > GdiplusShutdown function
【外部リンク】Windows > Apps > Win32 > API > GDI+ > Gdiplusinit.h > GdiplusStartup function
【外部リンク】Windows > Apps > Win32 > API > Component Object Model (COM) > Olectl.h >  PICTDESC structure
【外部リンク】Windows > Apps > Win32 > API > Component Object Model (COM) > Combaseapi.h >  IIDFromString
【外部リンク】Windows > Apps > Win32 >  Desktop Technologies > System Services  > Component Object Model (COM) >  PICTYPE Constants

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="LoadPng">
          <button id="Button1" label="画像ファイル" keytip="L" screentip="画像ファイル" getImage="getImage"
                  size="large" supertip="Png形式の画像ファイルを読み込みます。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

LoadImageModule
Option Explicit

' https://docs.microsoft.com/ja-jp/dotnet/framework/additional-apis/stdole.stdpicture
Private Const IID_IPictureDisp As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"

' https://docs.microsoft.com/en-us/windows/win32/com/pictype-constants
Private Enum PICTYPE
  UNINITIALIZED = -&O1
  NONE = &O0
  bitmap = &O1
  METAFILE = &O2
  Icon = &O3
  ENHMETAFILE = &O4
End Enum
'Private Const PICTYPE_BITMAP As Long = 1
  
' https://docs.microsoft.com/ja-jp/windows/win32/api/gdiplusinit/ns-gdiplusinit-gdiplusstartupinput
Private Type GdiplusStartupInput
  GdiplusVersion As Long
  DebugEventCallback As Long
  SuppressBackgroundThread As Long
  SuppressExternalCodecs As Long
End Type

#If Win64 Then

  ' https://docs.microsoft.com/en-us/windows/win32/api/olectl/ns-olectl-pictdesc
  Private Type PICTDESC
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
  End Type
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/gdiplus/-gdiplus-bitmap-flat
  Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus.dll" (ByVal FileName As LongPtr, bitmap As LongPtr) As LongPtr
  Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus.dll" (ByVal bitmap As LongPtr, hbmReturn As LongPtr, ByVal background As Long) As LongPtr ' background ?
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/gdiplus/-gdiplus-image-flat
  Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus.dll" (ByVal image As LongPtr) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/gdiplusinit/nf-gdiplusinit-gdiplusshutdown
  Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus.dll" (ByVal token As LongPtr) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/gdiplusinit/nf-gdiplusinit-gdiplusstartup
  Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus.dll" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/olectl/nf-olectl-olecreatepictureindirect
  Private Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (PicDesc As PICTDESC, RefIID As Long, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/combaseapi/nf-combaseapi-iidfromstring
  Private Declare PtrSafe Function IIDFromString Lib "Ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As Long

#Else
  Private Type PICTDESC
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
  End Type
    
  Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus.dll" (ByVal FileName As Long, bitmap As Long) As Long
  Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus.dll" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
  Private Declare Function GdipDisposeImage Lib "GDIPlus.dll" (ByVal image As Long) As Long
  Private Declare Function GdiplusShutdown Lib "GDIPlus.dll" (ByVal token As Long) As Long
  Private Declare Function GdiplusStartup Lib "GDIPlus.dll" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
  Private Declare Function IIDFromString Lib "Ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
  Private Declare Function OleCreatePictureIndirect Lib "OlePro32.dll" (PicDesc As PICTDESC, RefIID As Long, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  ' Windows Vistaは、 OleAut32.dllはなく、OlePro32.dll ?  Windows 10は、OleAut32.dll
  'Private Declare Function OleCreatePictureIndirect Lib "OleAut32.dll" (PicDesc As PICTDESC, RefIID As Long, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#End If

#If Win64 Then
Private Function ConvertToIPicture(ByVal hPic As LongPtr) As IPicture
#Else
Private Function ConvertToIPicture(ByVal hPic As Long) As IPicture
#End If
  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), VarPtr(IID(0)))
  Call OleCreatePictureIndirect(uPicInfo, IID(0), True, IPic)
  Set ConvertToIPicture = IPic
End Function

Public Function LoadImage(ByVal strFName As String) As IPicture
#If Win64 Then
  Dim hGdiPlus As LongPtr
  Dim hGdiImage As LongPtr
  Dim hBitmap As LongPtr
#Else
  Dim hGdiPlus As Long
  Dim hGdiImage As Long
  Dim hBitmap As Long
#End If
  Dim uGdiInput As GdiplusStartupInput

  uGdiInput.GdiplusVersion = 1&

  If GdiplusStartup(hGdiPlus, uGdiInput) = 0& Then
    If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0& Then
      Call GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0&)
      Set LoadImage = ConvertToIPicture(hBitmap)
      Call GdipDisposeImage(hGdiImage)
    End If
    Call GdiplusShutdown(hGdiPlus)
  End If
End Function
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン
Private ImageFlag As Boolean '

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  ImageFlag = True
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "Button1"
      ImageFlag = Not ImageFlag
      rbRibbonUI.InvalidateControl "Button1" ' リボンの表示を更新します。
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  
  Exit Sub
'
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub

Sub getImage(control As IRibbonControl, ByRef image) ' 画像の設定
  Select Case control.ID
    Case "Button1"
      If ImageFlag = True Then
        Set image = LoadImage(ThisWorkbook.Path & "\image1.png")
      Else
        Set image = LoadImage(ThisWorkbook.Path & "\image2.png")
      End If
  End Select
End Sub
このページの上