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

IconDialog


【ファイル名】IconDialog.xlsm
【バージョン】Ver 1.0.0.1
【作成日】2019年05月10日
【更新日】2021年04月22日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】IconDialog.zip
【説明】アイコンのダイアログのサンプルです。(Windows API)
サンプルタブ

アイコンのダイアログ
アイコンのダイアログ
Windows Vista以降のシェル アイコンのファイル名は「ImageRes.dll」、XPまでは「Shell32.dll」です。【参考】ImageRes.DLLのアイコン一覧

実行中のエクセルのウィンドウのタイトルバーの左端のアイコンを変更しました。(エクセルの2016以降は、変更できません)
ウィンドウのタイトルバーのアイコン

ステータスバーのエクセルのボタンのアイコンも変更されます。
ステータスバー

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="アイコン">
          <box id="Box1" boxStyle="vertical">
            <button id="IconDialogShell32Button" label="アイコンのダイアログ(&Shell32.dll)" imageMso="DataFormExcel" supertip="アイコンのダイアログを表示します。(Shell32.dll)" onAction="onAction" />
            <button id="IconDialogImageResButton" label="アイコンのダイアログ(&ImageRes.dll)" imageMso="DataFormExcel" supertip="アイコンのダイアログを表示します。(ImageRes.dll)" onAction="onAction" />
          </box>
          <separator id="separator1" />
          <box id="Box2" boxStyle="vertical">
            <button id="SetExcelIconButton" label="エクセルのアイコンを変更(&E)" imageMso="ExcelSpreadsheetInsert" 
                    supertip="エクセルのウィンドウのタイトルバーの左端のアイコンを選択したアイコンに変更します。&#13;バージョンによっては、変更できません。" onAction="onAction" />
            <button id="RestoreExcelIconButton" label="エクセルの既定のアイコン(&R)" imageMso="MicrosoftExcel" 
                    supertip="エクセルのウィンドウのタイトルバーの左端のアイコンを、エクセルの既定のアイコンに戻します。" onAction="onAction" />
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上
下記のマイクロソフトのサイトを参考にしました。
【外部リンク】Windows > Apps > Win32 > API > The Windows Shell > Shlobj_core.h > PickIconDlg function
【外部リンク】Windows > Apps > Win32 > API > The Windows Shell > Shellapi.h > ExtractIconW function
【外部リンク】Windows > Apps > Win32 > API > Windows and Messages > Winuser.h > SendMessageW function
【外部リンク】Windows > Apps > Win32 > API > Windows and Messages > Winuser.h > GetClassLongPtrW function
【外部リンク】Windows > Apps > Win32 > API > Windows and Messages > Winuser.h > GetClassLongW function

clsIconDialog
Option Explicit
' Show・・・アイコンのダイアログを表示します。
' FileName・・・アイコンを含むファイル名(既定は、ImageRes.dll)
' IconIndex・・・ファイル内の0始まりのアイコンの番号

#If Win64 Then
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shlobj_core/nf-shlobj_core-pickicondlg
  Private Declare PtrSafe Function PickIconDialog Lib "shell32.dll" Alias "PickIconDlg" (ByVal Handle As LongPtr, ByVal pszFileName As LongPtr, ByVal cchIconPath As Long, ByRef piIconIndex As LongPtr) As Long
#Else
  Private Declare Function PickIconDialog Lib "shell32.dll" Alias "PickIconDlg" (ByVal Handle As Long, ByVal pszFileName As LongPtr, ByVal cchIconPath As Long, ByRef piIconIndex As Long) As Long
#End If

Private Const MAX_PATH = 260&

Private m_FileName As String
Private m_IconIndex As Long

Public Property Get IconIndex() As Long ' ファイル内の0始まりのアイコンの番号
  IconIndex = m_IconIndex
End Property
Public Property Let IconIndex(NewValue As Long)
  m_IconIndex = NewValue
End Property

Public Property Get FileName() As String ' アイコンを含むファイル
  FileName = m_FileName
End Property
Public Property Let FileName(NewValue As String)
  m_FileName = NewValue
End Property

Public Function Show() As Boolean ' アイコンのダイアログを表示する
  Dim IconFileName As String
#If Win64 Then
  Dim SelectIconIndex As LongPtr
#Else
  Dim SelectIconIndex As Long
#End If
  
  IconFileName = String(MAX_PATH, vbNullChar)
''  IconFileName = StrConv(FileName + vbNullChar, vbUnicode)
  IconFileName = FileName + vbNullChar
  SelectIconIndex = IconIndex
  If PickIconDialog(Application.hwnd, StrPtr(IconFileName), MAX_PATH, SelectIconIndex) <> 0 Then
    IconIndex = CLng(SelectIconIndex)
''    FileName = StrVBA(StrConv(IconFileName, vbFromUnicode))
    FileName = StrVBA(IconFileName)
    Show = True
  Else
    Show = False
  End If
End Function

Private Sub Class_Initialize() ' 初期処理
  IconIndex = 0
  FileName = "ImageRes.dll" ' Windows XPまでシェル アイコンは、"%SystemRoot%\System32\SHELL32.dll"
End Sub

' 指定したヌルで終わる文字列から、vbNullCharの左側の文字列を取得します。
Private Function StrVBA(ByVal EndNullString As String) As String
  Dim p As Long
  
  p = InStr(1, EndNullString, vbNullChar)
  If p > 0 Then
    StrVBA = Left(EndNullString, p - 1)
  Else
    StrVBA = EndNullString ' ■ vbNullCharがない場合は引数をそのまま返します。
'    StrVBA = vbNullString ' ■ 必要に応じて変更してください。
  End If
End Function
このページの上

Module1
Option Explicit

#If Win64 Then
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shellapi/nf-shellapi-extracticonw
  Public 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/en-us/windows/desktop/api/winuser/nf-winuser-getclasslongptrw
  Public Declare PtrSafe Function GetClassLongPtr Lib "user32" Alias "GetClassLongPtrW" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
  
  ' https://docs.microsoft.com/en-us/windows/desktop/api/winuser/nf-winuser-sendmessagew
  Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Public ExcelIcon As LongPtr ' Excelのアイコン
#Else
  Public Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconW" (ByVal hInst As Long, ByVal lpszExeFileName As Long, ByVal nIconIndex As Long) As Long
  ' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getclasslongw
  Public Declare Function GetClassLongPtr Lib "user32" Alias "GetClassLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Public ExcelIcon As Long ' Excelのアイコン
#End If

Private Const GCL_HICON = -14
Private Const WM_GETICON = &H7F& ' ウィンドウのタイトルバーの左端のアイコンを取得
Private Const WM_SETICON = &H80& ' ウィンドウのタイトルバーの左端のアイコンを設定
Private rbRibbonUI As IRibbonUI  ' リボン

Enum ICON_SIZE
  SMALL_ICON = 0
  BIG_ICON = 1
End Enum

' Excelのアイコンを取得
#If Win64 Then
Function GetExcelIcon() As LongPtr
#Else
Function GetExcelIcon() As Long
#End If
  GetExcelIcon = GetClassLongPtr(Application.hwnd, GCL_HICON)
''  GetExcelIcon = SendMessage(Application.hwnd, WM_GETICON, 0, 0) ' できない?
End Function

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 "IconDialogShell32Button" ' アイコンのダイアログ(&amp;Shell32.dll)
      ShowIconDialog FileName:="Shell32.dll", IconIndex:=3
    Case "IconDialogImageResButton" ' アイコンのダイアログ(&amp;ImageRes.dll)
      ShowIconDialog FileName:="ImageRes.dll", IconIndex:=5
    Case "SetExcelIconButton" ' エクセルのアイコンを変更
      Call SetSelectExcelIcon
    Case "RestoreExcelIconButton" ' エクセルの既定のアイコン
      SetExcelIcon Excel:=True
    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

' Excelのウィンドウのタイトルバーの左端のアイコンを変更します。(タスクバーのボタンのアイコン)
' 【注意】Excelのバージョンによっては、できません。
Sub SetExcelIcon(Optional ByVal FileName As String = "shell32.dll", Optional ByVal IconIndex As Long = 0, Optional ByVal Excel As Boolean = False)
#If Win64 Then
  Dim hIcon As LongPtr
#Else
  Dim hIcon As Long
#End If
  
  If Excel Then ' Excelのウィンドウの既定のアイコンに戻します。
      SendMessage Application.hwnd, WM_SETICON, ICON_SIZE.BIG_ICON, ExcelIcon ' 大きいアイコン
      SendMessage Application.hwnd, WM_SETICON, ICON_SIZE.SMALL_ICON, ExcelIcon ' 小さいアイコン
  Else
    hIcon = ExtractIcon(0, StrPtr(FileName + vbNullChar), IconIndex) ' ファイルから指定した番号のアイコンの取得する
    If hIcon <> 0 Then
      SendMessage Application.hwnd, WM_SETICON, ICON_SIZE.BIG_ICON, hIcon ' 大きいアイコン
      SendMessage Application.hwnd, WM_SETICON, ICON_SIZE.SMALL_ICON, hIcon ' 小さいアイコン
    End If
  End If
End Sub

' アイコンのダイアログを表示して選択したアイコンに、Excelのウィンドウのアイコンを変更します。
Sub SetSelectExcelIcon()
  Dim IconDialog As clsIconDialog
  
  Set IconDialog = New clsIconDialog
  IconDialog.IconIndex = 0
  IconDialog.FileName = "Shell32.dll"
  If IconDialog.Show() = False Then Exit Sub
  SetExcelIcon FileName:=IconDialog.FileName, IconIndex:=IconDialog.IconIndex, Excel:=False
End Sub

' アイコンのダイアログを表示し、選択したアイコンのファイル名と番号を表示します。
Sub ShowIconDialog(Optional ByVal FileName As String = "shell32.dll", Optional ByVal IconIndex As Long = 0)
  Dim Msg As String
  Dim IconDialog As clsIconDialog
  Set IconDialog = New clsIconDialog
  
  IconDialog.IconIndex = IconIndex
  IconDialog.FileName = FileName
  If IconDialog.Show() Then
    Msg = "ファイル名:" & IconDialog.FileName & vbNewLine & vbNewLine & "アイコン番号:" & IconDialog.IconIndex
    MsgBox Prompt:=Msg, Buttons:=vbInformation, Title:="情報"
  End If
End Sub
このページの上

ThisWorkbook
Option Explicit

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
  If ExcelIcon = 0 Then
    ExcelIcon = GetExcelIcon
  End If
End Sub
このページの上