'mdlIcon----------------------------------------------------------------------------------------
Option Compare Database
Option Explicit

Declare Function ExtractIconEx Lib "shell32" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phIconLarge As Any, phIconSmall As Any, ByVal nIcons As Long) As Long
Declare Function DestroyIcon Lib "USER32" (ByVal hIcon&) As Long

'「アイコンの変更」ダイアログ
Declare Function SHChangeIconDialog Lib "shell32" Alias "#62" (ByVal hWnd As Long, ByVal szFilename As String, ByVal Reserved As Long, lpIconIndex As Long) As Long

'Systemフォルダ取得
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Function LsGetSystemDirectory() As String
    'Systemフォルダ取得
    Const cBufSize = 256
    Dim StrBuf As String * cBufSize
    Dim rc As Long

    rc = GetSystemDirectory(StrBuf, cBufSize)
    If rc > 0 Then
        LsGetSystemDirectory = Left$(StrBuf, rc)
    End If
End Function
'----------------------------------------------------------------------------------------------
'mdlMsgBox-------------------------------------------------------------------------------------
Option Compare Database
Option Explicit

' MessageBox() Flags
Public Const MB_OK = &H0&                      '「了解」
Public Const MB_OKCANCEL = &H1&                '「了解」「取消」
Public Const MB_ABORTRETRYIGNORE = &H2&        '「中止」「再試行」「無視」
Public Const MB_YESNOCANCEL = &H3&             '「はい」「いいえ」「取消」
Public Const MB_YESNO = &H4&                   '「はい」「いいえ」
Public Const MB_RETRYCANCEL = &H5&             '「再試行」「取消」

Public Const MB_ICONHAND = &H10&               '「Stop」アイコン
Public Const MB_ICONQUESTION = &H20&           '「?」アイコン
Public Const MB_ICONEXCLAMATION = &H30&        '「ｉ」アイコン
Public Const MB_ICONASTERISK = &H40&           '「!」アイコン

Public Const MB_ICONINFORMATION = MB_ICONASTERISK
Public Const MB_ICONSTOP = MB_ICONHAND

Public Const MB_DEFBUTTON1 = &H0&              '1番目をデフォルトに
Public Const MB_DEFBUTTON2 = &H100&            '2番目をデフォルトに
Public Const MB_DEFBUTTON3 = &H200&            '3番目をデフォルトに
Public Const MB_DEFBUTTON4 = &H300&            '4番目をデフォルトに

Public Const MB_APPLMODAL = &H0&               '
Public Const MB_SYSTEMMODAL = &H1000&          '
Public Const MB_TASKMODAL = &H2000&            '
Public Const MB_HELP = &H4000                  'ヘルプボタンを追加

Declare Function MessageBox Lib "USER32" Alias "MessageBoxA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long) As Long
'----------------------------------------------------------------------------------------------
'mdlRecent-------------------------------------------------------------------------------------
Option Compare Database
Option Explicit

' 最近使ったファイル(Recent)にファイル名を追加または削除する
'Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long, pv As Any)
Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long, ByVal pv As String)
    'uFlags pvの意味を指定
        Public Const SHARD_PATH = &H2 'pvはPath名である
        Public Const SHARD_PIDL = &H1 'pvはITEMIDLLIST構造体である
    'pv Path名またはITEMIDLLIST構造体を指定。vbNullStringでリストを全削除

' シェルについてダイアログを表示する関数の宣言
Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" _
    (ByVal hWnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
'----------------------------------------------------------------------------------------------
'form1-----------------------------------------------------------------------------------------
Option Compare Database
Option Explicit
Dim lpszFile As String, phIconLarge() As Long, phIconSmall() As Long, nIcons As Long
Dim CallFlg As Boolean

Private Sub cmdRecentAdd_Click()
    Dim pv As String

    ' 追加するファイル名。ファイルの実在チェックはしていません。
    pv = Environ("windir") & "\test.txt"
    ' 最近使ったファイル(Recent)にファイル名を追加
    SHAddToRecentDocs SHARD_PATH, pv
End Sub

Private Sub cmdRecentDel_Click()
    'vbNullStringをしていすると最近使ったファイル(Recent)のファイル名を削除
    SHAddToRecentDocs SHARD_PATH, vbNullString
End Sub

Private Sub cmdShellAbout_Click()
    Dim szApp As String
    Dim szOtherStuff As String
    Dim hIcon As Long
    Dim lngWin32apiResultCode As Long
    Dim rc  As Long, i As Long
    
    CallFlg = True
    cmdExtractIconEx_Click
    
    'キャプションタイトル
    szApp = "シェルについてのダイアログを表示"
    'ダイアログ内に表示するテキスト
    szOtherStuff = "Copyright (C) 2000 Loadsystem Co." & vbNewLine & "VBA ToolBox (http://www.loadsystem.nwt/)"
    'アイコンハンドル(0でMicrosoftのロゴアイコン)
    hIcon = phIconLarge(0)
    
    ' シェルについてのダイアログを表示
    lngWin32apiResultCode = ShellAbout(Me.hWnd, szApp, szOtherStuff, hIcon)
    CallFlg = False
    
    'ハンドル開放
    For i = 0 To nIcons - 1
        rc = DestroyIcon(phIconLarge(i))
        rc = DestroyIcon(phIconSmall(i))
    Next i
End Sub

Private Sub cmdMessageBox_Click()
    Dim rc As Long, uType As Long
    
    uType = MB_ABORTRETRYIGNORE Or MB_ICONINFORMATION Or MB_DEFBUTTON4 Or MB_HELP
    rc = MessageBox(Me.hWnd, "MessageBoxのサンプル。VBAのMsgBoxとほとんど同じです。またVBではMsgBox表示中タイマーの表示が中断されますが、MessageBox APIでは通常通り表示されます。", "MessageBoxのサンプル", uType)
End Sub

Private Sub cmdChangeIconDialog_Click()
    Dim wFile As String
    Dim idx As Long

    wFile = ""
    idx = 0

    If LsChangeIconDialog(Me.hWnd, wFile, idx) = 1 Then
        '[Ok]ボタンが押された
        MsgBox ("アイコンファイル名 = " & wFile & vbCr & "アイコン番号 = " & idx)
    Else
        MsgBox "キャンセルされました"
    End If

End Sub

Public Function LsChangeIconDialog(hWnd As Long, ByRef IconFile As String, ByRef Iconindex As Long) As Long
'---------------------------------------------------------------------
'「アイコンの変更」ダイアログ
'       hwnd = 呼び出し元のウインドウハンドル
'      IconFile = アイコンファイル名をセット(指定しなければShell32.dll)
'       IconIndex =アイコン番号(0〜255)をセット
'Return 1=[Ok]ボタンが押された
'       0=[キャンセル]ボタンが押された
'       IconFile = 選択されたアイコンファイル名
'       IconIndex =選択されたアイコン番号
'---------------------------------------------------------------------
    Dim rc As Long
    Dim szFilename As String

    If IconFile = "" Then 'アイコンファイルがない場合、Shell32.DLL
        szFilename = LsGetSystemDirectory() & "\SHELL32.DLL" & vbNullChar
        Iconindex = 0
    Else
        szFilename = IconFile & vbNullChar
    End If
    rc = SHChangeIconDialog(hWnd, szFilename, 0, Iconindex)
    If rc = 1 Then IconFile = Left$(szFilename, InStr(szFilename, vbNullChar) - 1)
    LsChangeIconDialog = rc
End Function

Private Sub cmdExtractIconEx_Click()
    Dim rc  As Long, i As Long
    
    lpszFile = Environ("WINDIR") & "\explorer.exe"
    
    'アイコン数取得
    nIcons = ExtractIconEx(lpszFile, -1, ByVal 0&, ByVal 0&, 0)
    
    MsgBox lpszFile & " のアイコン数は " & nIcons & "個です。"
    
    'アイコン数に応じてハンドルを受け取る長整数配列のサイズを確保
    ReDim phIconLarge(nIcons - 1) As Long, phIconSmall(nIcons - 1) As Long
    
    'アイコンハンドル取得
    nIcons = ExtractIconEx(lpszFile, 0, phIconLarge(0), phIconSmall(0), nIcons)
    
    If CallFlg Then Exit Sub 'cmdShellAbout_ClickからCallされた
    
    'ハンドル開放
    For i = 0 To nIcons - 1
        rc = DestroyIcon(phIconLarge(i))
        rc = DestroyIcon(phIconSmall(i))
    Next i
End Sub
'----------------------------------------------------------------------------------------------