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

ExtractIcon


【ファイル名】ExtractIcon.xlsm
【バージョン】Ver 1.0.0.2
【作成日】2021年05月08日
【更新日】2021年06月13日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】ExtractIcon.zip
【説明】Windows APIのExtractIconW関数でファイルからアイコンを取得するサンプルです。
メニュー
アイコンはOSによって異なります。

【外部リンク】Windows > Apps > Win32 > API > Menus and Other Resources > Winuser.h >  DestroyIcon DrawIcon
【外部リンク】Windows > Apps > Win32 > API > The Windows Shell > Shellapi.h >  ExtractIconW
【外部リンク】Windows > Apps > Win32 > API > Windows Accessibility Features > Oleacc.h > WindowFromAccessibleObject
【外部リンク】Windows > Apps > Win32 > API > Windows GDI > Winuser.h >  GetDCReleaseDC

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="アイコンの取得">
          <button id="ShowFormButton" label="フォームを表示(&amp;S)" supertip="フォームを表示します。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

UserForm1
Option Explicit
    
#If Win64 Then
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-destroyicon
  Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-drawicon
  Private Declare PtrSafe Function DrawIcon Lib "user32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal hIcon As LongPtr) 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/desktop/api/oleacc/nf-oleacc-windowfromaccessibleobject
  Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal pacc As Object, phwnd As LongPtr) As Long
  
  ' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getdc
  Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
  
  ' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-releasedc
  Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long

#Else
  Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
  Private Declare Function DrawIcon Lib "user32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) 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 WindowFromAccessibleObject Lib "oleacc.dll" (ByVal pacc As Object, phwnd As Long) As Long
  Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
#End If

'アイコンを取得する
Private Sub CommandButton1_Click()
  Dim i As Long
  Dim xpos As Long: xpos = 8
  Dim ypos As Long: ypos = 50
#If Win64 Then
  Dim IconMax  As LongPtr ' アイコンの数
  Dim hIcon   As LongPtr ' アイコンのハンドル
  Dim myHwnd   As LongPtr
  Dim myhDC   As LongPtr
#Else
  Dim IconMax  As Long
  Dim hIcon   As Long
  Dim myHwnd   As Long
  Dim myhDC   As Long
#End If
  
  UserForm1.Repaint ' フォームの描画をクリアーする
#If Win64 Then
  IconMax = ExtractIcon(Application.HinstancePtr, StrPtr(ComboBox1.Text), -1) ' アイコンの数を取得する
#Else
  IconMax = ExtractIcon(Application.Hinstance, StrPtr(ComboBox1.Text), -1)
#End If
  TextBox2.Text = IconMax ' アイコンの数
  If IconMax = 0 Then Exit Sub
  WindowFromAccessibleObject Me, myHwnd ' フォームのハンドルを取得する
  myhDC = GetDC(myHwnd)
  
  For i = 1 To CLng(IconMax)
#If Win64 Then
    hIcon = ExtractIcon(Application.HinstancePtr, StrPtr(ComboBox1.Text), i - 1) ' アイコンのハンドルを取得する
#Else
    hIcon = ExtractIcon(Application.Hinstance, StrPtr(ComboBox1.Text), i - 1)
#End If
    Call DrawIcon(myhDC, xpos, ypos, hIcon) ' アイコンを描画する
    Call DestroyIcon(hIcon) ' アイコンのハンドルを削除する
    
    If i Mod 30 = 0 Then
      xpos = 8
      ypos = ypos + 32 + 8
    Else
      xpos = xpos + 32 + 8
    End If
  Next
    
  ReleaseDC myHwnd, myhDC
End Sub

Private Sub UserForm_Initialize()
  ComboBox1.AddItem "ImageRes.dll"
  ComboBox1.AddItem "Shell32.dll"
  ComboBox1.AddItem "C:\Windows\Explorer.exe"
  ComboBox1.AddItem "C:\Program Files\Internet Explorer\IExplore.exe"
  ComboBox1.AddItem "C:\Windows\System32\compstui.dll"
  ComboBox1.AddItem "C:\Windows\System32\dsuiext.dll"
  ComboBox1.AddItem "C:\Windows\System32\FXSRESM.dll"
  ComboBox1.AddItem "C:\Windows\System32\IEFrame.dll"
  ComboBox1.AddItem "C:\Windows\System32\inetcpl.cpl"
  ComboBox1.AddItem "C:\Windows\System32\mmcndmgr.dll"
  ComboBox1.AddItem "C:\Windows\System32\MorIcons.dll"
  ComboBox1.AddItem "C:\Windows\System32\NetShell.dll"
  ComboBox1.AddItem "C:\Windows\System32\PifMgr.dll"
  ComboBox1.AddItem "C:\Windows\System32\SetupAPI.dll"
  ComboBox1.AddItem "C:\Windows\System32\SyncCenter.dll"
  ComboBox1.AddItem "C:\Windows\System32\wmploc.dll"
  ComboBox1.ListIndex = 0
End Sub
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン

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

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "ShowFormButton"
      UserForm1.Show vbModal
    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
このページの上