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

ExtractAssociatedIcon


【ファイル名】ExtractAssociatedIcon.xlsm
【バージョン】Ver 1.0.0.1
【作成日】2021年05月13日
【更新日】2021年06月13日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】ExtractAssociatedIcon.zip
【説明】Windows APIのExtractAssociatedIconW関数で、ファイルに関連付けられたアイコンを取得します。
メニュー
アイコンはOSによって異なります。

【外部リンク】Windows > Apps > Win32 > API > The Windows Shell > Shellapi.h >  ExtractAssociatedIconW
【外部リンク】Windows > Apps > Win32 > API > Menus and Other Resources > Winuser.h >  DestroyIconDrawIcon
【外部リンク】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
    
Private Const MAX_PATH = 260 ' パスの最大文字数
    
#If Win64 Then
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/shellapi/nf-shellapi-extractassociatediconw
  Private Declare PtrSafe Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconW" (ByVal hInst As LongPtr, ByVal lpIconPath As LongPtr, lpiIcon As Long) As LongPtr
  
  ' 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/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 ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconW" (ByVal hInst As Long, ByVal lpIconPath As Long, lpiIcon As Long) As Long
  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 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 lpIconPath As String ' ファイル名
  Dim lpiIcon As Long ' アイコンの0始まりの番号
#If Win64 Then
  Dim hIcon   As LongPtr ' アイコンのハンドル
  Dim myHwnd   As LongPtr
  Dim myhDC   As LongPtr
#Else
  Dim hIcon   As Long
  Dim myHwnd   As Long
  Dim myhDC   As Long
#End If
  
  UserForm1.Repaint ' フォームの描画をクリアーする
  
  If Len(TextBox1.Text) < 1 Then
    MsgBox Prompt:="ファイル名を入力してください。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    TextBox1.SetFocus
    Exit Sub
  End If
  
  lpIconPath = Replace(TextBox1.Text, """", "") ' 二重引用符を削除する
  
  If Len(lpIconPath) >= MAX_PATH Then ' ヌルを除く数(MAX_PATH -1)
    MsgBox Prompt:="入力した文字数が多すぎます。(259文字以下)", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    TextBox1.SetFocus
    Exit Sub
  End If
  
  lpIconPath = lpIconPath & String(MAX_PATH - Len(lpIconPath), vbNullChar)
  
#If Win64 Then ' 拡張子に関連付けられたアイコンの名前と番号を取得する。 関連付けがない場合は「C:\WINDOWS\System32\SHELL32.dll, 1」です。
  hIcon = ExtractAssociatedIcon(Application.HinstancePtr, StrPtr(lpIconPath), lpiIcon)
#Else
  hIcon = ExtractAssociatedIcon(Application.Hinstance, StrPtr(lpIconPath), lpiIcon)
#End If
  
  If hIcon = 0 Then
    MsgBox Prompt:="アイコンを取得できません。", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
    TextBox1.SetFocus
    Exit Sub
  End If
  
  TextBox2.Text = Left(lpIconPath, InStr(lpIconPath, vbNullChar) - 1) & ", " & CStr(lpiIcon) ' アイコンのファイル名と0始まりの番号

' アイコンの描画 >----------------------------------------------------------------------------------------------------------------
  WindowFromAccessibleObject Me, myHwnd ' フォームのハンドルを取得する
  myhDC = GetDC(myHwnd)

  Call DrawIcon(myhDC, 152, 90, hIcon) ' アイコンを描画する
  Call DestroyIcon(hIcon) ' アイコンのハンドルを削除する
    
  ReleaseDC myHwnd, myhDC
End Sub

Private Sub UserForm_Initialize()
  TextBox1.Text = ThisWorkbook.FullName
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
このページの上