' Structure d'un GUID
Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

' Structure contenant des infos sur une image
Public Type PICTDESC
    ' Normalement cette structure contient une union mais VB ne les gère pas
    cbSizeofStruct As Long      ' Taille de cette structure
    picType As Long            ' Type d'image : ICON, BITMAP, METAFILE, ENHMETAFILE
    ' Début union
        hImage As Long          ' Handle de l'image
        xExt As Long            ' Taille x de l'image pour une METAFILE
        yExt As Long            ' Taille y de l'image pour une METAFILE
End Type

' picType de PICTDESC pour une ICON
Public Const PICTYPE_ICON = 3

'permet de convertir une structure PICTDESC (et donc un handle d'image) en un IPictureDisp (= StdPicture)
Public Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef lpPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef lplpvObj As IPictureDisp)


' Récupérer l'icône associé au fichier et le dessiner
Public 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
Public Declare Function ImageList_GetIcon Lib "comctl32.dll" (ByVal himl&, ByVal i&, ByVal flags&) As Long
Public Const DJM_SMALLICON = &H6605
Public Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type
Public Declare Function ExtractAssociatedIcon Lib "Shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon As Long) As Long
Public Const DI_MASK = &H1
Public Const DI_IMAGE = &H2
Public Const DI_NORMAL = DI_MASK Or DI_IMAGE


' Récupère l'icone d'un fichier
' en 16*16
Public Function GetFileIcon16(ByRef FileName As String) As IPictureDisp
    ' La variable qui va contenir l'identifiant de l'icône
    Dim hIco        As Long
    Dim hIcon      As Long
    Dim SHFinfo    As SHFILEINFO
    hIco = SHGetFileInfo(FileName, 0&, SHFinfo, Len(SHFinfo), DJM_SMALLICON)
    hIcon = ImageList_GetIcon(hIco, SHFinfo.iIcon, 0)
    Set GetFileIcon16 = GetIconFromHandle(hIcon)
    ' Efface l'icône qui a été extrait
    DestroyIcon hIcon
End Function


' Récupère l'icone d'un fichier
' en 32*32
Public Function GetFileIcon32(ByRef FileName As String) As IPictureDisp
    ' La variable qui va contenir l'identifiant de l'icône
    Dim hIcon      As Long
    hIcon = ExtractAssociatedIcon(App.hInstance, FileName, 2)
    Set GetFileIcon32 = GetIconFromHandle(hIcon)
    ' Efface l'icône qui a été extrait
    DestroyIcon hIcon
End Function


' Convertit un pointeur vers un icone en IPictureDisp utilisable dans VB
' hIcon : handle de l'icone à convertir
' Renvoie une interface IPictureDisp (ou StdPicture pour VB)
Public Function GetIconFromHandle(hIcon As Long) As IPictureDisp
    ' Le REFIID de IPictureDisp (=GUID)
    Dim IID_IPictureDisp As GUID
    ' Infos sur l'icone
    Dim lpIcon As PICTDESC
    'on met place l'IID de IPictureDisp
    IID_IPictureDisp.Data1 = &H7BF80981
    IID_IPictureDisp.Data2 = &HBF32
    IID_IPictureDisp.Data3 = &H101A
    IID_IPictureDisp.Data4(0) = &H8B
    IID_IPictureDisp.Data4(1) = &HBB
    IID_IPictureDisp.Data4(2) = &H0
    IID_IPictureDisp.Data4(3) = &HAA
    IID_IPictureDisp.Data4(4) = &H0
    IID_IPictureDisp.Data4(5) = &H30
    IID_IPictureDisp.Data4(6) = &HC
    IID_IPictureDisp.Data4(7) = &HAB
    ' On initialise les champs requis :
    lpIcon.cbSizeofStruct = Len(lpIcon)
    lpIcon.hImage = hIcon
    ' le type : ICON
    lpIcon.picType = PICTYPE_ICON
    'on demande la création d'une interface de type IPictureDisp pour le handle d'icône
    'et en indiquant de ne pas effacer le HICON quand l'interface est libéré
    OleCreatePictureIndirect lpIcon, IID_IPictureDisp, 0, GetIconFromHandle
End Function