add icon associated with file ext. to ImageList

[smchristensen]

Is there a way to get the icons associated with a file and load them into a imagelist?

[Andyb]

This should get you started!!

Open a New Project
Add
1# Image list
1# Drive Control
1# Dir/Folder Control
1# File Control
1# Picture Box Control
7# Image Controls

Private Const MAX_PATH = 260

Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Private Enum EShellGetFileInfoConstants
SHGFI_ICON = &H100 ' // get icon
SHGFI_DISPLAYNAME = &H200 ' // get display name
SHGFI_TYPENAME = &H400 ' // get type name
SHGFI_ATTRIBUTES = &H800 ' // get attributes
SHGFI_ICONLOCATION = &H1000 ' // get icon location
SHGFI_EXETYPE = &H2000 ' // return exe type
SHGFI_SYSICONINDEX = &H4000 ' // get system icon index
SHGFI_LINKOVERLAY = &H8000 ' // put a link overlay on icon
SHGFI_SELECTED = &H10000 ' // show icon in selected state
SHGFI_ATTR_SPECIFIED = &H20000 ' // get only specified attributes
SHGFI_LARGEICON = &H0 ' // get large icon
SHGFI_SMALLICON = &H1 ' // get small icon
SHGFI_OPENICON = &H2 ' // get open icon
SHGFI_SHELLICONSIZE = &H4 ' // get shell size icon
SHGFI_PIDL = &H8 ' // pszPath is a pidl
SHGFI_USEFILEATTRIBUTES = &H10 ' // use passed dwFileAttribute
End Enum

Public Enum EGetIconTypeConstants
egitSmallIcon = 1
egitLargeIcon = 2
End Enum

Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
lpPictDesc As PictDesc, _
riid As Guid, _
ByVal fPictureOwnsHandle As Long, _
ipic As IPicture _
) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _
(ByVal pszPath As String, ByVal dwAttributes As Long, psfi As SHFILEINFO, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long

Private Sub Dir1_Change()
File1.Path = Dir1
End Sub

Private Sub Drive1_Change()
Dir1.Path = Drive1
End Sub


Private Function GetIcon(ByVal sFIle As String, Optional ByVal EIconType As EGetIconTypeConstants = egitLargeIcon) As Object
Dim lR As Long
Dim hIcon As Long
Dim tSHI As SHFILEINFO
Dim lFlags As Long

' Prepare flags for SHGetFileInfo to get the icon:
If (EIconType = egitLargeIcon) Then
lFlags = SHGFI_ICON Or SHGFI_LARGEICON
Else
lFlags = SHGFI_ICON Or SHGFI_SMALLICON
End If
lFlags = lFlags And Not SHGFI_LINKOVERLAY
lFlags = lFlags And Not SHGFI_OPENICON
lFlags = lFlags And Not SHGFI_SELECTED
' Call to get icon:
lR = SHGetFileInfo(sFIle, 0&, tSHI, Len(tSHI), lFlags)
If (lR <> 0) Then
' If we succeeded, the hIcon member will be filled in:
hIcon = tSHI.hIcon
' If we have an icon, convert it to a VB picture and return it:
If Not (hIcon = 0) Then
Set GetIcon = IconToPicture(hIcon)
End If
End If

End Function

Private Function IconToPicture(ByVal hIcon As Long) As IPicture

If hIcon = 0 Then Exit Function
Dim NewPic As Picture, PicConv As PictDesc, IGuid As Guid

PicConv.cbSizeofStruct = Len(PicConv)
PicConv.picType = vbPicTypeIcon
PicConv.hImage = hIcon

'IGuid.Data1 = &H20400
'IGuid.Data4(0) = &HC0
'IGuid.Data4(7) = &H46
' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
With IGuid
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
OleCreatePictureIndirect PicConv, IGuid, True, NewPic

Set IconToPicture = NewPic

End Function


Private Sub File1_Click()
On Local Error Resume Next ' image control or image list may go out of bounds here
Dim TheFile
Dim i

TheFile = Dir1.Path & "\" & File1.filename
Picture1.Picture = GetIcon(TheFile)
ImageList1.ListImages.Add ImageList1.ListImages.Count + 1, "Pic" & ImageList1.ListImages.Count + 1, Picture1.Picture
Caption = ImageList1.ListImages.Count

For i = 0 To ImageList1.ListImages.Count - 1
Image1(i).Picture = ImageList1.ListImages(i + 1).Picture
Next
End Sub


Regards
Andy