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

ExtractIcon2


【ファイル名】ExtractIcon2.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年05月11日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】ExtractIcon2.zip
【説明】Windows APIのExtractIcon関数でファイルからアイコンを取得して一覧を表示するサンプルです。
メニュー
アイコンはOSによって異なります。また透明のアイコンもあります。

【外部リンク】Programming Field > プログラミング > プログラミング Tips >  VB 6.0 における画像ハンドルの変換
【外部リンク】Windows > Apps > Win32 > API > The Windows Shell > Shellapi.h >  ExtractIconW
【外部リンク】Windows > Apps > Win32 > API > Component Object Model (COM) > Olectl.h >  OleCreatePictureIndirect
【外部リンク】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="ExtractIcon" keytip="S" insertBeforeMso="TabHome">
        <group id="group1" label="アイコン">
          <comboBox id="comboBox1" label="ファイル名:" keytip="F" getText="getText" onChange="onChange"
            screentip="comboBox" supertip="リストを選択か入力して[Enter]キーを押してください。"
            maxLength="1024" sizeString="MMMMMWWWWWMMMMMWWWWWMMMMMWWWWWMMMMMWWWWW">
            <item id="Item01" label="ImageRes.dll" />
            <item id="Item02" label="shell32.dll" />
            <item id="Item03" label="C:\Windows\Explorer.exe" />
            <item id="Item04" label="C:\Program Files\Internet Explorer\IExplore.exe" />
            <item id="Item05" label="C:\Windows\System32\dsuiext.dll" />
            <item id="Item06" label="C:\Windows\System32\FXSRESM.dll" />
            <item id="Item07" label="C:\Windows\System32\IEFrame.dll" />
            <item id="Item08" label="C:\Windows\System32\inetcpl.cpl" />
            <item id="Item09" label="C:\Windows\System32\mmcndmgr.dll" />
            <item id="Item10" label="C:\Windows\System32\MorIcons.dll" />
            <item id="Item11" label="C:\Windows\System32\NetShell.dll" />
            <item id="Item12" label="C:\Windows\System32\PifMgr.dll" />
            <item id="Item13" label="C:\Windows\System32\SetupAPI.dll" />
            <item id="Item14" label="C:\Windows\System32\SyncCenter.dll" />
            <item id="Item15" label="C:\Windows\System32\wmploc.dll" />
          </comboBox>
          <button id="button1" label="アイコンの取得" keytip="I" size="large" screentip="アイコンの取得"
                  supertip="ファイルからアイコンを取得します。" imageMso="HappyFace" onAction="onAction" />

          <separator id="separator1" />

          <gallery id="gallery1" label="アイコンの一覧" keytip="L" imageMso="Heart" size="large" showItemLabel="true"
                   showItemImage="true" columns="10" onAction="gallery_onAction" itemWidth="32" itemHeight="32"
                   getEnabled="getEnabled" supertip="ファイルからアイコンの一覧を表示します。"
                   getItemCount="getItemCount" getItemID="getItemID" getItemLabel="getItemLabel" getItemImage="getItemImage" >
          </gallery>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

IconModule
Option Explicit

' 【参考サイト】VB 6.0 における画像ハンドルの変換
' https://www.pg-fl.jp/program/tips/vb60img.htm

' 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
Enum PICTYPE
  UNINITIALIZED = -&O1
  NONE = &O0
  BITMAP = &O1
  METAFILE = &O2
  Icon = &O3
  ENHMETAFILE = &O4
End Enum

#If Win64 Then
  ' https://docs.microsoft.com/en-us/windows/win32/api/olectl/ns-olectl-pictdesc
  Private Type PICTDESC
    cbSizeOfStruct As Long
    PICTYPE As Long
    Handle As LongPtr       ' hbitmap, hmeta, hicon, hemf
    Param1 As LongPtr       ' hpal, xExt, 0, 0
  End Type

  ' https://docs.microsoft.com/ja-jp/windows/win32/api/olectl/nf-olectl-olecreatepictureindirect
  Private Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (ByRef pPictDesc As PICTDESC, ByRef RefIID As Long, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/shellapi/nf-shellapi-extracticonw
  Private Declare PtrSafe Function ExtractIcon Lib "Shell32.dll" Alias "ExtractIconW" (ByVal hInst As LongPtr, ByVal lpszExeFileName As LongPtr, ByVal nIconIndex As Long) As LongPtr

  ' 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
    cbSizeOfStruct As Long
    PICTYPE As Long
    Handle As Long       ' hbitmap, hmeta, hicon, hemf
    Param1 As Long       ' hpal, xExt, 0, 0
  End Type
  
  Private Declare Function OleCreatePictureIndirect Lib "OlePro32.dll" (pPictDesc As PICTDESC, RefIID As Long, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
' Windows Vistaは、 OleAut32.dllはなく、OlePro32.dll ?
'  Private Declare Function OleCreatePictureIndirect Lib "OleAut32.dll" (ByRef pPictDesc As PICTDESC, ByRef RefIID As Long, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  Private Declare Function ExtractIcon Lib "Shell32.dll" Alias "ExtractIconW" (ByVal hInst As Long, ByVal lpszExeFileName As Long, ByVal nIconIndex As Long) As Long
  Private Declare Function IIDFromString Lib "Ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
#End If

    ' hIcon からピクチャオブジェクトを作成する関数
#If Win64 Then
Private Function hIconToPicture(ByVal hIcon As LongPtr) As stdole.IPictureDisp
#Else
Private Function hIconToPicture(ByVal hIcon As Long) As stdole.IPictureDisp
#End If
  Dim pic As stdole.IPictureDisp
  Dim hr As Long
  Dim pd As PICTDESC
  Dim IID(0 To 3) As Long
  
  pd.Handle = hIcon
  pd.cbSizeOfStruct = Len(pd)
  pd.PICTYPE = PICTYPE.Icon
  Set pic = Nothing
  Call IIDFromString(StrPtr(IID_IPictureDisp), VarPtr(IID(0)))
  hr = OleCreatePictureIndirect(pd, IID(0), 1, pic)
  
  If hr < 0 Then ' エラー
    Call VBA.Information.Err().Raise(hr)
    Exit Function
  End If
  
  Set hIconToPicture = pic
End Function

Public Function GetIcon(Optional ByVal IconFile As String = "ImageRes.DLL", Optional ByVal IconIndex As Long = 0) As stdole.IPictureDisp
#If Win64 Then
  Dim hIcon As LongPtr
#Else
  Dim hIcon As Long
#End If
  
  hIcon = ExtractIcon(Application.Hwnd, StrPtr(IconFile), IconIndex)
  If hIcon = 0 Then Exit Function
  Set GetIcon = hIconToPicture(hIcon)
End Function

Public Function GetIconCount(Optional ByVal IconFile As String = "ImageRes.DLL") As Long
#If Win64 Then
  Dim ret As LongPtr
#Else
  Dim ret As Long
#End If

  ret = ExtractIcon(Application.Hwnd, StrPtr(IconFile), -1)
  GetIconCount = CLng(ret)
End Function
Module1
Option Explicit

Private rbIRibbonUI As IRibbonUI ' リボン
Private rbText As String ' comboBoxの文字列
Private rbItemCount As Integer ' galleryの項目の数
Private rbEnabled As Boolean ' 有効・無効
Public IconList As Collection

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  rbText = "ImageRes.dll"
  rbEnabled = False ' 無効
  Set rbIRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbIRibbonUI.Invalidate ' リボンを更新
End Sub

Sub getText(control As IRibbonControl, ByRef returnedVal) ' comboBoxのテキストの設定
  returnedVal = rbText
End Sub

Sub onChange(control As IRibbonControl, text As String) ' comboBoxの変更イベント処理
  rbText = text ' comboBoxのテキストを取得
End Sub

Sub getItemCount(control As IRibbonControl, ByRef count) ' galleryの項目の数を設定
  count = rbItemCount
End Sub

Sub getItemID(control As IRibbonControl, index As Integer, ByRef itemID) ' galleryの項目のItemIDを設定
  itemID = control.ID & "Item" & CStr(index) ' IDは重複してはいけない
End Sub

Sub getItemLabel(control As IRibbonControl, index As Integer, ByRef returnedVal) ' galleryの項目のラベルを設定
  returnedVal = CStr(index)
End Sub

Sub getItemImage(control As IRibbonControl, index As Integer, ByRef image) ' galleryの項目の画像を設定
  Dim pic As stdole.IPictureDisp

  Set pic = GetIcon(rbText, CLng(index))
  IconList.Add pic
  Set image = pic
End Sub

Sub onAction(control As IRibbonControl) ' ボタンをクリックした時に、galleryの項目の設定を変更します
  Dim i As Long
  
  If Len(rbText) < 1 Then
    MsgBox Prompt:="ファイル名を入力してください。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    Exit Sub
  End If
  
  For i = IconList.count To 1 Step -1 ' コレクションのクリアー
    IconList.Remove i
  Next
  
  rbItemCount = GetIconCount(rbText)
  
  If rbItemCount > 0 Then
    rbEnabled = True
  Else
    rbEnabled = False
    MsgBox Prompt:="アイコンを取得できません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
  End If
  
  rbIRibbonUI.InvalidateControl "gallery1" ' galleryを更新
End Sub

Sub getEnabled(control As IRibbonControl, ByRef returnedVal)
  returnedVal = rbEnabled
End Sub
このページの上