Filelistview - filelistbox mais affiche aussi les icônes des fichiers listés

Télécharger le projet
Commenter

Description

Voilà j'ai travaillé là-dessus, et comme c'est pas vraiment simple ( même si on peut dire que c'est compliqué non plus... ) j'en fais profiter tout le monde.

Donc voilà, c'est comme un FileListBox mais il affiche aussi les icônes des fichiers.
Les procédure sont justes décrites, mais le code n'est pas commenté, c'est facile à comprendre.

Pour rentrer dans les détails on extrait les icônes de deux manières différentes :
- s'il s'agit d'un fichier .exe .ico .lnk .cur .bmp ( enfin bref des extensions avec des icônes variables ), on extrait l'icône du fichier et on l'ajoute dans la l'imagelist, avec pour key le chemin complet du fichier
- s'il s'agit d'une autre extension où l'icône est constante ( genre .vbs ) on regarde si l'extension n'a pas déjà entrée dans l'imagelist ( grâce à sa Key qui correspond à l'extension ) avec un simple
r = ImageFile.ListImages.Item(extension).Index
si l'erreur 35601 est généré, c'est qu'il trouve pas la key "extension" alors on l'ajoute avec pour key l'extension et après il l'a trouvera. Voilà voilà.

Sinon c'est plutôt rapide ( moins d'une seconde pour listé 500 fichiers sur PII-300 )
Et un petit détail, pour éviter de surcharger l'imagelist, à chaque fois qu'on recharge la liste de fichiers, on clear l'imagelist.

Source / Exemple : 


' Télécharger le zip c'est mieux parce qu'il y a un groupe de projet avec un exemple d'utilisation
' Sinon voici le source du contrôle
' Balancez ça dans notepad et enregistrer "FileListView.ctl"

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.UserControl FileListView 
   ClientHeight    =   3630
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4815
   ScaleHeight     =   242
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   321
   Begin VB.PictureBox picIcon 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H00800080&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   240
      Left            =   3720
      ScaleHeight     =   256
      ScaleMode       =   0  'User
      ScaleWidth      =   288
      TabIndex        =   1
      Top             =   1440
      Visible         =   0   'False
      Width           =   240
   End
   Begin MSComctlLib.ImageList ImageFile 
      Left            =   3480
      Top             =   120
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      MaskColor       =   8388736
      _Version        =   393216
   End
   Begin MSComctlLib.ListView file 
      Height          =   3615
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   3375
      _ExtentX        =   5953
      _ExtentY        =   6376
      View            =   3
      LabelEdit       =   1
      MultiSelect     =   -1  'True
      LabelWrap       =   -1  'True
      HideSelection   =   0   'False
      HideColumnHeaders=   -1  'True
      FullRowSelect   =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   1
      BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Object.Width           =   396875
      EndProperty
   End
End
Attribute VB_Name = "FileListView"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private Const ILD_TRANSPARENT = &H1      'Couleur de la transparence ( je me comprends, essayez de changer pour comprendre )

' Constantes pour SHFILEINFO

Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_EXETYPE = &H2000
Private Const SHGFI_SYSICONINDEX = &H4000
Private Const SHGFI_LARGEICON = &H0
Private Const SHGFI_SMALLICON = &H1
Private Const SHGFI_SHELLICONSIZE = &H4
Private Const SHGFI_TYPENAME = &H400

Private Const BASIC_SHGFI_FLAGS = SHGFI_TYPENAME _
        Or SHGFI_SHELLICONSIZE _
        Or SHGFI_SYSICONINDEX _
        Or SHGFI_DISPLAYNAME _
        Or SHGFI_EXETYPE
'Constantes combinnées ( grâce à l'opératuer "or" )le plus souvent utilisées lors de l'extraction d'une icône
'Combinez cette constante basique à une des constanctes SHGFI_LARGEICON ou SHGFI_SMALLICON grâce à "or" pour
'extraire les icônes avec la taille qui vous interresse

Private Type SHFILEINFO
    hIcon         As Long
    iIcon         As Long
    dwAttributes  As Long
    szDisplayName As String * 260
    szTypeName    As String * 80
End Type

' API utilisée pour extraire l'icône associé à un fichier
' Renvoie un nombre ( long ) qui représente le handle d'un icône ( qui varie à chaque sollicitation )
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _
    (ByVal pszPath As String, _
    ByVal dwFileAttributes As Long, _
    psfi As SHFILEINFO, _
    ByVal cbSizeFileInfo As Long, _
    ByVal uFlags As Long) As Long

' API utilisée pour dessiner dans un pictureBox une icône grâce à son Handle ( extrait avec l'API SHGetFileInfo )
Private Declare Function ImageList_Draw Lib "comctl32.dll" _
    (ByVal himl&, _
    ByVal i&, _
    ByVal hDCDest&, _
    ByVal x&, _
    ByVal y&, _
    ByVal flags&) As Long

Dim ShInfo        As SHFILEINFO

Dim Ctrl_Path     As String ' Variable dans laquelle est stocké le chemin du dossier où se trouvent les fichiers listés
Dim Ctrl_Pattern  As String ' Variable dans laquelle est stocké le Pattern des fichiers à lister

Event Click()
Event DblClick()
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Event ItemClick(ByVal Item As MSComctlLib.ListItem)
Event SelectFile(FileName As String, Fullpath As String)
Event PathChange(New_Path As String, Old_Path As String)

Private Sub file_Click()
    RaiseEvent Click
End Sub

Private Sub file_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub file_ItemClick(ByVal Item As MSComctlLib.ListItem)
    MsgBox Item.SmallIcon
    RaiseEvent ItemClick(Item)
    RaiseEvent SelectFile(Item.Text, Item.Key)
End Sub

Private Sub UserControl_Initialize()
    
    loadFileList App.Path, Ctrl_Pattern
    
End Sub

'************************************************************************************
' Charge la liste des fichiers du répertoire "Path" selon les conditions du "Pattern"
'************************************************************************************

Private Sub loadFileList(Path As String, Pattern As String)

    On Error GoTo error
    
    Dim listeFichier As String
    Dim itemx        As ListItem
    Dim fichier      As String
    Dim ShInfo       As SHFILEINFO
    Dim hIcon        As Long
    Dim imgx         As ListImage
    Dim fso          As Variant
    Dim extension    As String
    Dim WasSorted    As Boolean
    
    WasSorted = file.Sorted
    
    file.Sorted = False
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    file.ListItems.Clear
    file.Refresh
    
    file.SmallIcons = Nothing
    
    ImageFile.ListImages.Clear
    
    If Not Right(Path, 1) = "\" Then Path = Path & "\"
    
    Ctrl_Path = Path
    
    listeFichier = Dir(Path & Pattern, vbReadOnly + vbNormal + vbHidden + vbArchive + vbSystem)
    
    Do Until listeFichier = ""
            
        fichier = Path & listeFichier
            
        Set itemx = file.ListItems.Add(, fichier, listeFichier)
        itemx.Selected = False
        listeFichier = Dir
        
        extension = UCase(fso.GetExtensionName(fichier))
        
        Select Case extension
            Case "EXE"
            
                hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _
                BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)
        
                picIcon.Picture = Nothing
                
                ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT
                
                Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image)
            
            Case "ICO"
                hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _
                BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)
        
                picIcon.Picture = Nothing
                
                ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT
                
                Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image)
                
            Case "CUR"
                hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _
                BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)
        
                picIcon.Picture = Nothing
                
                ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT
                
                Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image)
                
            Case "BMP"
            
                hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _
                BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)
        
                picIcon.Picture = Nothing
                
                ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT
                
                Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image)
            
            Case "LNK"
            
                hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _
                BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)
        
                picIcon.Picture = Nothing
                
                ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT
                
                Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image)
            Case vbNullString
                
                hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _
                BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)
        
                picIcon.Picture = Nothing
                
                ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT
                
                Set imgx = ImageFile.ListImages.Add(, fichier, picIcon.Image)
            
                
            Case Else
                addIcon extension, fichier
                
        End Select
    Loop
    
    If file.ListItems.Count = 0 Then Exit Sub
    
    file.SmallIcons = ImageFile
    
    For Each itemx In file.ListItems
        
        fichier = itemx.Key
        
        extension = UCase(fso.GetExtensionName(fichier))
            
        If extension = "EXE" Or _
            extension = "ICO" Or _
            extension = "BMP" Or _
            extension = vbNullString Or _
            extension = "LNK" Then
            file.ListItems.Item(fichier).SmallIcon = fichier
        Else
            file.ListItems.Item(fichier).SmallIcon = extension
        End If
        
                    
    Next
    
    file.Sorted = WasSorted
    
    Exit Sub

error:
    If Err.Number = 7 Or Err.Number = 35600 Then Resume Next 'Survient lorsque la capacité de l'imagelist est dépassé ( environ 400 images )
    If Err.Number = 35601 Then Resume Next ' survient après la correction d'un key numérique
    If Err.Number = 35603 Then ' survient lorsque la key est numérique ( exemple si le fichier s'appelle chaipas.123)
        
        extension = "KEY_NEED2BE_A_STRING" & extension
        
        hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _
        BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)

        picIcon.Picture = Nothing
        
        ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT
        
        Set imgx = ImageFile.ListImages.Add(, extension, picIcon.Image)
        
        file.SmallIcons = ImageFile
        
        itemx.SmallIcon = extension
        
        Err.Clear
        Resume Next
    
    Else

        MsgBox "Une erreur inattendue est survenue." & vbCrLf & vbCrLf & "Numéro de l'erreur : " & vbCrLf & Err.Number & vbCrLf & vbCrLf & "Description de l'erreur : " & vbCrLf & Err.Description, vbExclamation, "Erreur..."
        Err.Clear
        Resume Next
    
    End If

End Sub

'*********************************************************************************
' Lors de la procédure LoadFileList qui liste les fichiers d'un répertoire,
' si l'extension du fichier ajouté est différente des fichiers à icones variables
' ( .ico par exemple )pour ne pas surcharger l'ImageList, et pour gagner du temps,
' on évite d'extraire plusieurs fois la même icône associée à une extension
'
'En gros et vu de loin, si l'îcone associé à "Extension" n'est pas trouvé
'dans l'ImageList, l'erreur 35601
'*********************************************************************************
Private Sub addIcon(extension As String, fichier As String)

    On Error GoTo error
    
    Dim r     As Variant
    Dim hIcon As Long
    Dim imgx  As ListImage
    
    r = ImageFile.ListImages.Item(extension).Index
    
    Exit Sub

error:

    If Err.Number = 35601 Then 'survient lorsque la key n'est pas trouvé
         
        hIcon = SHGetFileInfo(fichier, 0&, ShInfo, Len(ShInfo), _
        BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)

        picIcon.Picture = Nothing
        
        ImageList_Draw hIcon, ShInfo.iIcon, picIcon.hDC, 0, 0, ILD_TRANSPARENT
        
        Set imgx = ImageFile.ListImages.Add(, extension, picIcon.Image)
        Err.Clear
        Resume Next
    Else
        MsgBox "Une erreur inattendue est survenue." & vbCrLf & vbCrLf & "Numéro de l'erreur : " & vbCrLf & Err.Number & vbCrLf & vbCrLf & "Description de l'erreur : " & vbCrLf & Err.Description, vbExclamation, "Erreur..."
        Err.Clear
        Resume Next
    End If

End Sub

Private Sub File_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub File_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub File_KeyUp(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyUp(KeyCode, Shift)
    RaiseEvent SelectFile(file.SelectedItem.Text, file.SelectedItem.Key)
    RaiseEvent Click
End Sub

Private Sub File_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    RaiseEvent MouseDown(Button, Shift, x, y)
End Sub

Private Sub File_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    RaiseEvent MouseMove(Button, Shift, x, y)
End Sub

Private Sub File_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    RaiseEvent MouseUp(Button, Shift, x, y)
End Sub

Private Sub UserControl_Resize()
    
    file.Width = UserControl.ScaleWidth
    file.Height = UserControl.ScaleHeight - file.Top
    file.ColumnHeaders(1).Width = file.Width - 5
    
End Sub

Public Property Get Path() As String

    Path = Ctrl_Path

End Property

Public Property Let Path(ByVal New_Path As String)

    loadFileList New_Path, Ctrl_Pattern
    PropertyChanged "Path"

End Property

'*************************************
'Renvoie le nom du fichier selectionné
'*************************************
Public Property Get FileName() As String
    
    FileName = file.SelectedItem.Text
    
End Property

'************************************
'Selectionne un fichier dans la liste
'************************************
Public Property Let FileName(New_FileName As String)
    
    Dim i As Integer
    
    
    If Not New_FileName = "" Then
    
        
        For i = 1 To file.ListItems.Count
            If file.ListItems.Item(i).Text = New_FileName Then
                file.ListItems.Item(i).Selected = True
                Exit For
            End If
        Next i
    
    Else
        
        For i = 1 To file.ListItems.Count
            file.ListItems.Item(i).Selected = False
        Next i
        
    End If
        
End Property

Public Property Get Pattern() As String

    Pattern = Ctrl_Pattern
    
End Property

Public Property Let Pattern(ByVal New_Pattern As String)
    
    Ctrl_Pattern = New_Pattern
    loadFileList Ctrl_Path, New_Pattern
    PropertyChanged "Pattern"

End Property

Public Property Get ListCount() As Integer

    ListCount = file.ListItems.Count
    
End Property

Public Property Get ListIndex() As Integer

    ListIndex = file.SelectedItem.Index
    
End Property

Public Property Let ListIndex(New_ListIndex As Integer)

    file.ListItems.Item(New_ListIndex).Selected = True
    
End Property

Public Property Get Sorted() As Boolean

    Sorted = file.Sorted
    
End Property

Public Property Let Sorted(New_State As Boolean)

    file.Sorted = New_State
    
End Property

Public Sub Refresh()
    
    loadFileList Ctrl_Path, Ctrl_Pattern
    
End Sub

Public Sub RemoveItem(fichier As String)
    
    file.ListItems.Remove (fichier)
    
End Sub

Public Function HitTest(x As Single, y As Single)
    
    On Error GoTo error:
    
    HitTest = file.HitTest(x, y)

    Exit Function

error:
    
    HitTest = ""
    
End Function

Public Sub Selected(Item As Integer, State As Boolean)

    file.ListItems.Item(Item).Selected = State

End Sub

Public Sub Clear()

    file.ListItems.Clear

End Sub

Conclusion :


Merci T De Lange, 2000 ( tomdl@attglobal.net ) pour les informations sur les deux apis utilisées.
Sinon le code est de moi.

Pas encore vu de bugs.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_Alain Proviste)