Option Explicit

' Unicode-aware class to retrieve associated icons via Windows system image lists

Public Enum AssocIconSize ' defined by Windows, not me

aisLargeIcon32 = 0 ' 32x32
aisSmallIcon16 = 1 ' 16x16
aisExtraLargeIcon48 = 2 ' 48x48 XP+
aisJumboIcon256 = 4 ' 256x256 Vista+
End Enum

Public Enum AssocIconType ' defined by me

aitGenericIcon = 0 ' icon relative to file type
aitActualIcon = 1 ' icon actually associated with executables or special
folders
aitOpenedIcon = 2 ' icons may have a selected/open version. OR this
value; i.e., aitGenericIcon Or aitOpenedIcon
End Enum ' ^^ purposely same value as: SHGFI_OPENICON = 2

Private Const MAX_PATH As Long = 260&

'
[Link]
spx
Private Const SHGFI_PIDL As Long = &H8&
Private Const SHGFI_USEFILEATTRIBUTES As Long = &H10&
Private Const SHGFI_SYSICONINDEX As Long = &H4000&

Private Type SHFILEINFO '

[Link]
hIcon As Long ' icon handle
iIcon As Long ' icon index in system image list
dwAttributes As Long ' file/folder attributes
szDisplayName As String * MAX_PATH ' display name for the file/folder
szTypeName As String * 80 ' type of file
End Type

Private Const ILD_TRANSPARENT As Long = &H1&

Private Const INVALID_HANDLE_VALUE As Long = -1&
Private Const IID_IImageList As String = "{46EB5926-582E-4017-9FDF-
E8998DAA0950}"
'Private Const IID_IImageList2 As String = "{192B9D83-50FC-457B-90A0-
2B82A8B5DAE1}"

Private Declare Function SHGetFileInfo Lib "[Link]" Alias "SHGetFileInfoA"

(ByRef pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal
cbSizeFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function SHGetFileInfoW Lib "[Link]" (ByRef pszPath As Any,
ByVal dwFileAttributes As Long, ByVal psfi As Long, ByVal cbSizeFileInfo As Long,
ByVal uFlags As Long) As Long

Private Declare Function SHGetImageListXP Lib "[Link]" Alias "#727" (ByVal

iImageList As Long, ByRef riid As Long, ByRef ppv As Any) As Long
Private Declare Function SHGetImageList Lib "[Link]" (ByVal iImageList As
Long, ByRef riid As Long, ByRef ppv As Any) As Long
Private Declare Function IIDFromString Lib "[Link]" (ByVal lpsz As Long, ByRef
lpiid As Any) As Long
Private Declare Function ImageList_GetIcon Lib "[Link]" (ByVal hIML As Long,
ByVal i As Long, ByVal flags As Long) As Long
Private Declare Function GetVersion Lib "[Link]" () As Long
Private Declare Function GetDesktopWindow Lib "[Link]" () As Long
Private Declare Function IsWindowUnicode Lib "[Link]" (ByVal hWnd As Long) As
Long

Private Declare Function GetFileAttributes Lib "[Link]" Alias

"GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function GetFileAttributesW Lib "[Link]" (ByVal lpFileName As
Long) As Long

Private m_Version As Long ' 2=Vista or better 1=XP 0=other 4 = unicode

Public Function GetAssociatedIconEx(IconSource As Variant, ByVal IconSize As

AssocIconSize, ByVal IconType As AssocIconType) As Long

' IconSource can be in one of these formats

' A full path and/or filename. Required if IconType includes aitActualIcon
' Example. C:\Program Files\Internet Explorer\[Link]
' if IconType includes aitActualIcon then real IE icon is returned
else generic exe icon
' Any folder if wanting the generic folder icon. Specific folder icons
require full path of actual folder
' Example. C:\Documents and Settings\LaVolpe\Favorites\
' if IconType is aitActualIcon then a 'star' shaped icon is returned
on XP else generic folder icon
' when IconType is aitGenericIcon, ensure folders end with \
' Any valid lettered drive. IconType should be aitGenericIcon
' Example. C:\
' Any valid UNC. IconType can be either aitGenericIcon or aitActualIcon
' Example. \\company server\shared music\
' Any extension. IconType must be aitGenericIcon & extension preceded with
dot
' Example. .zip will return generic icon for WinZip documents
' A null string to retrieve the generic "unknown" file type icon. IconType
should be aitGenericIcon

' Numeric PIDL. Use variable type of Long

' PIDLs are always handled as if IconType is aitActualIcon
' If you want a generic icon type, you should expand your PIDL to a fully
qualified path/filename and pass that instead
' What is a PIDL? This may interest you. [Link]
support/faqs/[Link]

Dim lRtn As Long, lFlags As Long

Dim pIML As IUnknown, hIML As Long
Dim sPath As String, SHFI As SHFILEINFO
Dim GUID(0 To 3) As Long, lAttr As Long

' sanity checks first

If VarType(IconSource) = vbString Then
sPath = IconSource
ElseIf VarType(IconSource) = vbLong Then
lFlags = SHGFI_PIDL
Else
Exit Function
End If

If IconSize < aisLargeIcon32 Then ' validate passed icon size

IconSize = aisLargeIcon32
 ElseIf IconSize > aisJumboIcon256 Then
IconSize = aisJumboIcon256
ElseIf IconSize > aisExtraLargeIcon48 And IconSize < aisJumboIcon256 Then
IconSize = aisExtraLargeIcon48
End If
' validate icon size supported
If IconSize = aisExtraLargeIcon48 Then ' not
applicable for less than XP
If (m_Version And 3&) = 0 Then IconSize = aisLargeIcon32
ElseIf (IconSize = aisJumboIcon256) And ((m_Version And 3&) < 2&) Then ' only
for Vista+
If (m_Version And 3&) = 0 Then IconSize = aisLargeIcon32 Else IconSize =
aisExtraLargeIcon48
End If
' build the flags & attributes
API values
If (IconType And aitOpenedIcon) Then lFlags = lFlags Or aitOpenedIcon
If (IconType And aitActualIcon) Then
If (lFlags And SHGFI_PIDL) = 0 Then
If (m_Version And 4&) Then
lRtn = GetFileAttributesW(StrPtr(sPath))
Else
lRtn = GetFileAttributes(sPath)
End If
If lRtn = INVALID_HANDLE_VALUE Then
IconType = aitGenericIcon
lFlags = lFlags Or SHGFI_USEFILEATTRIBUTES
If Right$(sPath, 1) = "\" Then lAttr = vbDirectory
Else
If (lRtn And vbDirectory) = vbDirectory Then lAttr = vbDirectory
End If
End If
Else
If (lFlags And SHGFI_PIDL) = 0 Then
If Right$(sPath, 1) = "\" Then lAttr = vbDirectory
End If
lFlags = lFlags Or SHGFI_USEFILEATTRIBUTES
End If

If IconSize < aisExtraLargeIcon48 Then

lFlags = lFlags Or SHGFI_SYSICONINDEX Or IconSize
Else
lFlags = lFlags Or SHGFI_SYSICONINDEX
End If
' call the API
If (m_Version And 4&) Then ' unicode calls
If (lFlags And SHGFI_PIDL) Then lRtn = CLng(IconSource) Else lRtn =
StrPtr(sPath)
hIML = SHGetFileInfoW(ByVal lRtn, lAttr, VarPtr(SHFI), Len(SHFI), lFlags)
Else ' ansi system
If (lFlags And SHGFI_PIDL) Then
hIML = SHGetFileInfo(ByVal CLng(IconSource), lAttr, SHFI, Len(SHFI),
lFlags)
Else
hIML = SHGetFileInfo(ByVal sPath, lAttr, SHFI, Len(SHFI), lFlags)
End If
End If

' on XP and above, the image list handle returned by SHGetFileInfo is not the
ExtraLarge or Jumbo sized
' image lists as expected. We'll use SHGetImageList to get the correct handle

If hIML Then
If IconSize >= aisExtraLargeIcon48 Then ' XP or greater O/S
If IIDFromString(StrPtr(IID_IImageList), GUID(0)) = 0 Then
On Error Resume Next
lRtn = SHGetImageList(IconSize, GUID(0), ByVal VarPtr(pIML))
If lRtn = 0& Then
If Err Then ' depending on service pack shell32 did not
export SHGetImageList correctly
[Link] ' so we try again using the ordinal exported
lRtn = SHGetImageListXP(IconSize, GUID(0), ByVal
VarPtr(pIML))
If Err Then lRtn = hIML ' assign any non-zero value; will
be using the hIML value
End If
End If
On Error GoTo 0
If lRtn = 0& Then hIML = ObjPtr(pIML)
End If
End If
GetAssociatedIconEx = ImageList_GetIcon(hIML, [Link], ILD_TRANSPARENT)
End If

End Function

Private Sub Class_Initialize()

m_Version = GetVersion()
Select Case (m_Version And &HFF&)
Case Is > 5 ' Vista or better
m_Version = 2&
Case 5 ' XP or maybe not
If ((m_Version And &HFF00&) \ &H100 > 0&) Then m_Version = 1& Else
m_Version = 0&
Case Else ' less than XP
m_Version = 0&
End Select
If IsWindowUnicode(GetDesktopWindow) <> 0& Then m_Version = m_Version Or 4&

End Sub