Module Shell

    Private Declare Ansi Function SHGetFileInfo Lib "shell32.dll" (ByVal pszPath As String, ByVal dwFileAttributes As Integer, ByRef psfi As SHFILEINFO, ByVal cbFileInfo As Integer, ByVal uFlags As Integer) As IntPtr
    Private Const SHGFI_ICON As Long = &H100
    Private Const SHGFI_DISPLAYNAME As Long = &H200
    Private Const SHGFI_TYPENAME As Long = &H400
    Private Const SHGFI_ATTRIBUTES As Long = &H800
    Private Const SHGFI_ICONLOCATION As Long = &H1000
    Private Const SHGFI_EXETYPE As Long = &H2000
    Private Const SHGFI_SYSICONINDEX As Long = &H4000
    Private Const SHGFI_LINKOVERLAY As Long = &H8000
    Private Const SHGFI_SELECTED As Long = &H10000
    Private Const SHGFI_ATTR_SPECIFIED As Long = &H20000
    Private Const SHGFI_LARGEICON As Long = &H0
    Private Const SHGFI_SMALLICON As Long = &H1
    Private Const SHGFI_OPENICON As Long = &H2
    Private Const SHGFI_SHELLICONSIZE As Long = &H4
    Private Const SHGFI_PIDL As Long = &H8
    Private Const SHGFI_USEFILEATTRIBUTES As Long = &H10

    Private Structure SHFILEINFO
        Public hIcon As IntPtr
        Public iIcon As IntPtr
        Public dwAttributes As Integer
        <Runtime.InteropServices.MarshalAs(Runtime.InteropServices.UnmanagedType.ByValTStr, SizeConst:=260)> _
        Public szDisplayName As String
        <Runtime.InteropServices.MarshalAs(Runtime.InteropServices.UnmanagedType.ByValTStr, SizeConst:=80)> _
        Public szTypeName As String
    End Structure

    Public Function ExtractAssociatedIcon(ByVal path As String, Optional ByVal index As Integer = 0, Optional ByVal isSmallIcon As Boolean = False, Optional ByVal isFromExt As Boolean = False) As Drawing.Bitmap
        Dim shinfo As New SHFILEINFO
        Dim flg As Integer = SHGFI_ICON
        If isSmallIcon Then
            flg = flg Or SHGFI_SMALLICON
        Else
            flg = flg Or SHGFI_LARGEICON
        End If
        If isFromExt Then flg = flg Or SHGFI_USEFILEATTRIBUTES
        Dim hImg As IntPtr = SHGetFileInfo(path, index, shinfo, Runtime.InteropServices.Marshal.SizeOf(shinfo), flg)
        If hImg.Equals(IntPtr.Zero) Then
            Return Nothing
        Else
            ExtractAssociatedIcon = Drawing.Icon.FromHandle(shinfo.hIcon).Clone.ToBitmap
            DestroyIcon(shinfo.hIcon)
        End If
    End Function

    ' ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
    ' Original source "Programming Field" @ http://pf-j.sakura.ne.jp/
    ' 実行可能ファイルからのアイコンの抽出 for VB.NET http://pf-j.sakura.ne.jp/program/tips/icnvbnet.htm

    Private Const LR_DEFAULTCOLOR As Integer = &H0I
    Private Const LR_MONOCHROME As Integer = &H1I

    ' MyExtractIconData 用のデータ (Structure より Class の方が楽)
    Private Class MyExtractIconData
        Public Index As Integer
        Public NowPos As Integer
        Public Found As Boolean
        Public IsID As Boolean
        Public ID As UInteger
        Public Name As String
    End Class

    Private Const DONT_RESOLVE_DLL_REFERENCES As Integer = &H1I
    Private Const LOAD_LIBRARY_AS_DATAFILE As Integer = &H2I
    Private Const LOAD_WITH_ALTERED_SEARCH_PATH As Integer = &H8I
    Private Const LOAD_IGNORE_CODE_AUTHZ_LEVEL As Integer = &H10I
    Private Declare Ansi Function LoadLibraryEx Lib "kernel32.dll" Alias "LoadLibraryExA" _
     (ByVal lpLibFileName As String, ByVal hFile As System.IntPtr, _
     ByVal dwFlags As Integer) As System.IntPtr
    Private Declare Ansi Function FreeLibrary Lib "kernel32.dll" _
     (ByVal hModule As System.IntPtr) As Boolean
    Private Const RT_CURSOR As Integer = 1
    Private Const RT_BITMAP As Integer = 2
    Private Const RT_ICON As Integer = 3
    Private Const RT_MENU As Integer = 4
    Private Const RT_DIALOG As Integer = 5
    Private Const RT_STRING As Integer = 6
    Private Const RT_FONTDIR As Integer = 7
    Private Const RT_FONT As Integer = 8
    Private Const RT_ACCELERATOR As Integer = 9
    Private Const RT_RCDATA As Integer = 10
    Private Const RT_MESSAGETABLE As Integer = 11
    Private Const RT_GROUP_CURSOR As Integer = 12
    Private Const RT_GROUP_ICON As Integer = 14
    Private Const RT_VERSION As Integer = 16
    Private Const RT_DLGINCLUDE As Integer = 17
    Private Const RT_PLUGPLAY As Integer = 19
    Private Const RT_VXD As Integer = 20
    Private Const RT_ANICURSOR As Integer = 21
    Private Const RT_ANIICON As Integer = 22
    Private Const RT_HTML As Integer = 23
    Private Const RT_MANIFEST As Integer = 24

    ' コールバック関数をデリゲートで宣言します。
    Private Delegate Function EnumResNameProc(ByVal hInst As System.IntPtr, _
     ByVal lpszType As System.IntPtr, ByVal lpszName As System.IntPtr, _
     ByVal lParam As System.IntPtr) As Boolean

    Private Declare Ansi Function EnumResourceNames Lib "kernel32.dll" _
     Alias "EnumResourceNamesA" (ByVal hModule As System.IntPtr, _
     ByVal lpszType As System.IntPtr, ByVal lpEnumFunc As EnumResNameProc, _
     ByVal lParam As System.IntPtr) As Boolean

    ' 以下の 2 つは数値でも文字列でも呼び出せるようにしています。
    Private Declare Ansi Function FindResource Lib "kernel32.dll" Alias "FindResourceA" _
     (ByVal hModule As System.IntPtr, ByVal lpName As System.IntPtr, _
     ByVal lpType As System.IntPtr) As System.IntPtr
    Private Declare Ansi Function FindResource Lib "kernel32.dll" Alias "FindResourceA" _
     (ByVal hModule As System.IntPtr, ByVal lpName As String, _
     ByVal lpType As System.IntPtr) As System.IntPtr

    Private Declare Ansi Function LoadResource Lib "kernel32.dll" _
     (ByVal hModule As System.IntPtr, ByVal hResInfo As System.IntPtr) As System.IntPtr
    Private Declare Ansi Function LockResource Lib "kernel32.dll" _
     (ByVal hResData As System.IntPtr) As System.IntPtr
    Private Declare Ansi Function SizeofResource Lib "kernel32.dll" _
     (ByVal hModule As System.IntPtr, ByVal hResInfo As System.IntPtr) As Integer
    Private Declare Ansi Function LookupIconIdFromDirectoryEx Lib "user32.dll" _
     (ByVal pResBits As System.IntPtr, ByVal fIcon As Integer, ByVal cxDesired As Integer, _
     ByVal cyDesired As Integer, ByVal Flags As Integer) As Integer
    Private Declare Ansi Function CreateIconFromResource Lib "user32.dll" _
     (ByVal pResBits As System.IntPtr, ByVal dwResSize As Integer, ByVal fIcon As Integer, _
     ByVal dwVer As Integer) As System.IntPtr
    Private Declare Ansi Function CreateIconFromResourceEx Lib "user32.dll" _
     (ByVal pResBits As System.IntPtr, ByVal dwResSize As Integer, ByVal fIcon As Integer, _
     ByVal dwVer As Integer, ByVal cxDesired As Integer, ByVal cyDesired As Integer, ByVal colFlag As Integer) As System.IntPtr

    Private Declare Auto Function DestroyIcon Lib "user32.dll" _
     (ByVal hIcon As System.IntPtr) As Boolean

    Private Function MyEnumResNameProc(ByVal hInst As System.IntPtr, _
     ByVal lpszType As System.IntPtr, ByVal lpszName As System.IntPtr, _
     ByVal lParam As System.IntPtr) As Boolean
        Dim strName As String
        Dim ptr As System.Runtime.InteropServices.GCHandle = System.Runtime.InteropServices.GCHandle.FromIntPtr(lParam)
        Dim Data As MyExtractIconData
        Data = ptr.Target
        If Data.NowPos = Data.Index Then
            Data.Found = True
            Data.IsID = ((lpszName.ToInt32() And &HFFFF0000I) = 0)
            If Not Data.IsID Then
                strName = System.Runtime.InteropServices.Marshal.PtrToStringAnsi(lpszName)
                Data.Name = strName
            Else
                Data.ID = (lpszName.ToInt32() And &HFFFFI)
            End If
            Return False
        End If
        Data.NowPos = Data.NowPos + 1
        Return True
    End Function

    Private Function MyExtractIcon(ByVal PathName As String, ByVal IndexOrID As Integer, _
      ByVal SmallIcon As Boolean) As System.IntPtr
        Dim hInstance As System.IntPtr
        Dim hRes As System.IntPtr, hRes2 As System.IntPtr
        Dim hMem As System.IntPtr, hMem2 As System.IntPtr
        Dim lpv As System.IntPtr, lpv2 As System.IntPtr
        Dim Data As MyExtractIconData, ptr As System.Runtime.InteropServices.GCHandle

        hInstance = LoadLibraryEx(PathName, 0, LOAD_LIBRARY_AS_DATAFILE Or _
         LOAD_WITH_ALTERED_SEARCH_PATH)
        If hInstance = 0 Then Return 0

        Data = New MyExtractIconData
        If IndexOrID < 0 Then
            Data.IsID = True
            Data.ID = -(IndexOrID + 1)
            Data.Found = True
        Else
            Data.Index = IndexOrID
            Data.NowPos = 0
            Data.Found = False
            ptr = System.Runtime.InteropServices.GCHandle.Alloc(Data)
            Call EnumResourceNames(hInstance, RT_GROUP_ICON, AddressOf MyEnumResNameProc, ptr)
            Call ptr.Free()
            If Not Data.Found Then
                Call FreeLibrary(hInstance)
                Return 0
            End If
        End If

        If Data.IsID Then
            hRes = FindResource(hInstance, CType(Data.ID, System.IntPtr), _
             CType(RT_GROUP_ICON, System.IntPtr))
        Else
            hRes = FindResource(hInstance, Data.Name, CType(RT_GROUP_ICON, System.IntPtr))
        End If
        If hRes <> 0 Then
            hMem = LoadResource(hInstance, hRes)
            lpv = LockResource(hMem)
            Data.ID = LookupIconIdFromDirectoryEx(lpv, True, _
             IIf(SmallIcon, 16, 32), IIf(SmallIcon, 16, 32), _
             LR_DEFAULTCOLOR)
            If Data.ID <> 0 Then
                hRes2 = FindResource(hInstance, CType(Data.ID, System.IntPtr), _
                 CType(RT_ICON, System.IntPtr))
                hMem2 = LoadResource(hInstance, hRes2)
                lpv2 = LockResource(hMem2)
                MyExtractIcon = CreateIconFromResourceEx(lpv2, _
                 SizeofResource(hInstance, hRes2), 1, &H30000I, IIf(SmallIcon, 16, 32), IIf(SmallIcon, 16, 32), LR_DEFAULTCOLOR)
            End If
        End If
        Call FreeLibrary(hInstance)
    End Function

    ' GetIconImageFromDLL は、DLL 名とインデックス (または絶対値が ID になる負の値)
    ' を指定するだけでアイコンオブジェクトを取得できます。
    ' PathName を省略すると "shell32.dll" になります
    Public Function GetIconImageFromDLL(ByVal PathName As String, ByVal IndexOrID As Integer, _
     Optional ByVal SmallIcon As Boolean = False) As System.Drawing.Icon
        Dim hIcon As System.IntPtr
        If PathName = Nothing OrElse PathName = "" Then PathName = "shell32.dll"
        hIcon = MyExtractIcon(PathName, IndexOrID, SmallIcon)
        If hIcon = 0 Then
            Return Nothing
        Else
            ' FromHandle では Dispose でアイコンを自動的に削除してくれないので作成しなおす
            GetIconImageFromDLL = System.Drawing.Icon.FromHandle(hIcon).Clone()
            DestroyIcon(hIcon)
        End If
    End Function

End Module
