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&

'
http://msdn.microsoft.com/en-us/library/windows/desktop/bb762179%28v=vs.85%29.a
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 '

http://msdn.microsoft.com/en-us/library/windows/desktop/bb759792%28v=VS.85%29.aspx
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 "shell32.dll" 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 "shell32.dll" (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 "shell32.dll" Alias "#727" (ByVal

iImageList As Long, ByRef riid As Long, ByRef ppv As Any) As Long
Private Declare Function SHGetImageList Lib "shell32.dll" (ByVal iImageList As
Long, ByRef riid As Long, ByRef ppv As Any) As Long
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByRef
lpiid As Any) As Long
Private Declare Function ImageList_GetIcon Lib "comctl32.dll" (ByVal hIML As Long,
ByVal i As Long, ByVal flags As Long) As Long
Private Declare Function GetVersion Lib "kernel32.dll" () As Long
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function IsWindowUnicode Lib "user32.dll" (ByVal hWnd As Long) As
Long

Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias

"GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function GetFileAttributesW Lib "kernel32.dll" (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\iexplore.exe
' 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. http://ccrp.mvps.org/index.html?
support/faqs/faqbrowse.htm

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
Err.Clear ' 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, SHFI.iIcon, 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