FileListBox avec icones

Bonjour/soir,

C'est tout à fait possible à partir d'un contrôle listview associé à un
imagelist.
Exemple:

'Dans une feuille, Form1
'Ajouter Microsoft Windows Common Controls 6 dans la boite à outils
'Une imagelist, ImageList1
'Une Listview, ListView1

Option Explicit

Private Sub Form_Load()
'On va comencer par ajouter les fichiers à la racine du c
Dim MyIcon As Picture
Dim strBuffer As String

strBuffer = Dir("c:")

Do While Len(strBuffer)
'On tente de récupérer un icône
Set MyIcon = GetFileIconLarge("c:" & strBuffer)

'Si on l'a récupérée, on l'ajoute à la collection d'images
If Not MyIcon Is Nothing Then
ImageList1.ListImages.Add , strBuffer, MyIcon
ListView1.ListItems.Add , , strBuffer, strBuffer
Else
ListView1.ListItems.Add , , strBuffer
End If
Set MyIcon = Nothing
'On ajoute une item à la listview


strBuffer = Dir
Loop

'On peut aussi ajouter un fichier par son extension
Set MyIcon = GetFileIconLarge("toto.jpg")
'Si on l'a récupérée, on l'ajoute à la collection d'images
If Not MyIcon Is Nothing Then
'* est interdit dans un nom de fichier. On sera donc sûr que l'item
n'existe pas déjà
ImageList1.ListImages.Add , "*testicon", MyIcon
ListView1.ListItems.Add , , "testitem", "*testicon"
Else
ListView1.ListItems.Add , , "testitem"
End If
Set MyIcon = Nothing

'Ou retrouver un exécutable sans son path complet
Set MyIcon = GetFileIconLarge2("calc.exe")
'Si on l'a récupérée, on l'ajoute à la collection d'images
If Not MyIcon Is Nothing Then
ImageList1.ListImages.Add , "*calc", MyIcon
ListView1.ListItems.Add , , "calc.exe", "*calc"
Else
ListView1.ListItems.Add , , "calc.exe"
End If
Set MyIcon = Nothing
End Sub

'Dans un module du nom IconFromFile:
Option Explicit

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 Declare Function SHGetFileInfo _
Lib "shell32.dll" _
Alias "SHGetFileInfoA" _
( _
ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
psfi As SHFILEINFO, _
ByVal cbFileInfo As Long, _
ByVal uFlags As Long _
) _
As Long

Private Declare Function DestroyIcon _
Lib "user32" _
( _
ByVal hIcon As Long _
) _
As Long

Private Enum SHGFI_FLAGS
SHGFI_ICON = &H100
SHGFI_DISPLAYNAME = &H200
SHGFI_TYPENAME = &H400
SHGFI_ATTRIBUTES = &H800
SHGFI_ICONLOCATION = &H1000
SHGFI_EXETYPE = &H2000
SHGFI_SYSICONINDEX = &H4000
SHGFI_LINKOVERLAY = &H8000
SHGFI_SELECTED = &H10000
SHGFI_ATTR_SPECIFIED = &H20000
SHGFI_LARGEICON = &H0
SHGFI_SMALLICON = &H1
SHGFI_OPENICON = &H2
SHGFI_SHELLICONSIZE = &H4
SHGFI_PIDL = &H8
SHGFI_USEFILEATTRIBUTES = &H10
End Enum

Private Type PICTDESC
cbSizeOfStruct As Long
picType As Long
hPicture 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 fOwn As Long, _
ppvObj As Any _
) _
As Long

Private Declare Function ExtractIconEx _
Lib "shell32.dll" _
Alias "ExtractIconExA" _
( _
ByVal lpszFile As String, _
ByVal nIconIndex As Long, _
phiconLarge As Long, _
phiconSmall As Long, _
ByVal nIcons As Long _
) _
As Long

Public Function GetFileIconLarge(strFileName As String) As Picture
Dim Infos As SHFILEINFO
Dim hLargeIcon As Long

If SHGetFileInfo(strFileName, _
0, _
Infos, _
Len(Infos), _
SHGFI_FLAGS.SHGFI_ICON Or SHGFI_FLAGS.SHGFI_LARGEICON Or
SHGFI_FLAGS.SHGFI_USEFILEATTRIBUTES) Then

If Infos.hIcon Then
Set GetFileIconLarge = GetPictureFromIcon(Infos.hIcon)
End If
End If
End Function

Public Function GetFileIconLarge2(strFileName As String) As Picture
Dim hLargeIcon As Long

If ExtractIconEx(strFileName, 0, hLargeIcon, ByVal 0&, 1) = 1 Then
Set GetFileIconLarge2 = GetPictureFromIcon(hLargeIcon)
End If
End Function

Public Function GetFileIconSmall(strFileName As String) As Picture
Dim Infos As SHFILEINFO
Dim hSmallIcon As Long

If SHGetFileInfo(strFileName, _
0, _
Infos, _
Len(Infos), _
SHGFI_FLAGS.SHGFI_ICON Or SHGFI_FLAGS.SHGFI_SMALLICON Or
SHGFI_FLAGS.SHGFI_USEFILEATTRIBUTES) Then

If Infos.hIcon Then
Set GetFileIconSmall = GetPictureFromIcon(Infos.hIcon)
End If
End If
End Function

Public Function GetFileIconSmall2(strFileName As String) As Picture
Dim hSmallIcon As Long

If ExtractIconEx(strFileName, 0, ByVal 0&, hSmallIcon, 1) = 1 Then
Set GetFileIconSmall2 = GetPictureFromIcon(hSmallIcon)
End If
End Function

Public Function GetPictureFromIcon(hIcon As Long) As IPicture
Dim PictureDesc As PICTDESC
Dim IPictureGUID As GUID
Dim PictureObject As Picture

PictureDesc.cbSizeOfStruct = Len(PictureDesc)
PictureDesc.hPicture = hIcon
PictureDesc.picType = vbPicTypeIcon

'{7BF80980-BF32-101A-8BBB-00AA00300CAB}
With IPictureGUID
.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 PictureDesc, IPictureGUID, True, PictureObject
Set GetPictureFromIcon = PictureObject

End Function

--
François Picalausa (MVP VB)
FAQ VB : http://faq.vb.free.fr
MSDN : http://msdn.microsoft.com


"eon2" <ahhedrole@hotmail.com> a écrit dans le message de
news:c1cbp6$1nc$1@news.tiscali.fr

Existe t'il un moyen d'afficher les icones des fichiers dans une
FileListBox ou un controle simmilaire?

Merci