MINI-EXPLORATEUR DE FICHIERS

Téléchargement : dépend de la version du composant Active X Microsoft Windows Common Controls enregistré :
- Si version 5 : COMCTL32.OCX : VBExplore5.zip
- Si version 6 : MSCOMCTL.OCX : VBExplore6.zip

J'avais besoin dans certaines de mes applications d'afficher la liste des fichiers d'un répertoire donné dans une fenêtre propriétaire (par exemple, la liste des documents liés à un client, un patient, un employé, ...).
Bien sûr, il serait simple d'ouvrir une fenêtre d'exploration, style "Explorateur Windows", mais je voulais que cette liste soit affichée dans un contrôle ListView au sein d'une feuille VB.

De plus, je voulais :

  • que les icônes associées aux fichiers soient les mêmes que celles de l'explorateur Windows
  • qu'un double-clic lance l'application par défaut pour ce fichier

Le projet comporte un module (APIMod.bas) et une feuille (Form1).
La feuille contient : un ListView (LV1), un bouton (Cmd1), un groupe de 2 boutons (CmdView), un label (LblTitre) et un label (LblCount).
Principe :
 On commence par demander à l'utilisateur de choisir un répertoire (en fait, dans mes applis, le répertoire est défini par le choix d'un utilisateur dans une base de données).
On recherche ensuite les fichiers présents et on charge leurs noms dans un contrôle ListView.
Pour les icônes associées, on doit associer le contrôle ListView aux ImageLists du système Windows (il y en a 2 : les petites et les grandes icônes).
Ensuite, pour chaque fichier, on doit rechercher l'index de son icône associée dans les ImageLists de Windows.
Module ModAPI.bas - Déclarations :

' CONSTANTES POUR LISTVIEW
' ========================
Public Const LVM_FIRST = &H1000
Public Const LVM_SETBKCOLOR = (LVM_FIRST + 1)
Public Const LVM_SETIMAGELIST = (LVM_FIRST + 3)
Public Const LVM_GETITEMCOUNT = (LVM_FIRST + 4)
    #If UNICODE Then
        Public Const LVM_SETITEM = (LVM_FIRST + 76)
    #Else
        Public Const LVM_SETITEM = (LVM_FIRST + 6)
    #End If
Public Const LVM_REDRAWITEMS = (LVM_FIRST + 21)
Public Const LVM_SETTEXTCOLOR = (LVM_FIRST + 36)
Public Const LVM_SETTEXTBKCOLOR = (LVM_FIRST + 38)
Public Const LVM_UPDATE = (LVM_FIRST + 42)
Public Const LVM_SETITEMSTATE = (LVM_FIRST + 43)
    #If (WIN32_IE >= &H400) Then
        #If UNICODE Then
            Public Const LVM_SETBKIMAGE = (LVM_FIRST + 138)
        #Else
            Public Const LVM_SETBKIMAGE = (LVM_FIRST + 68)
        #End If
    #End If ' // WIN32_IE >= &H400

' CONSTANTES POUR IMAGELIST
' =========================
 Public Const LVSIL_NORMAL = 0
Public Const LVSIL_SMALL = 1
Public Const LVSIL_STATE = 2

Public Const SHGFI_LARGEICON = &H0 ' sfi.hIcon is large icon
Public Const SHGFI_SMALLICON = &H1 ' sfi.hIcon is small icon
Public Const SHGFI_SYSICONINDEX = &H4000

 ' CONSTANTES POUR LE MASK (membre de LV_ITEM)
' ========================================
Public Const LVIF_TEXT = &H1
Public Const LVIF_IMAGE = &H2
Public Const LVIF_PARAM = &H4
Public Const LVIF_STATE = &H8

' AUTRES
' ======
Public Const SW_SHOWNORMAL = 1
Public Const MAX_PATH = 256
Public Const BIF_RETURNONLYFSDIRS = &H1

' STRUCTURES
' ==========
Public Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hWnd As Long
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As Long
    ' Optional fields
        lpIDList As Long
        lpClass As String
        hkeyClass As Long
        dwHotKey As Long
        hIcon As Long
        hProcess As Long
End Type

Public Type LV_ITEM
    mask As Long
    iItem As Long
    iSubItem As Long
    state As Long
    stateMask As Long
    pszText As String
    cchTextMax As Long
    iImage As Long
    lParam As Long
    #If (WIN32_IE >= &H300) Then
        iIndent As Long
    #End If
End Type

Public Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type

Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

' FONCTIONS
' ==========
Public Declare Function ShellExecuteEx Lib "shell32.dll" (SEI As SHELLEXECUTEINFO) As Long

Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    wParam As Long, _
    lParam As Any) As Long ' <---

' Récupère les infos d'un objet du système de fichiers
' Un fichier, un répertoire, ou la racine d'un lecteur
Declare Function SHGetFileInfo Lib "shell32" 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 SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
    ByVal pszPath As String) As Long

Public Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Module ModAPI.bas - Routines :
Public Function GetSmallIconIndex(ByVal pszPath As String) As Long
' Cette procédure récupère l'index de l'icône à afficher depuis le ListImages système
' pszPath est le nom du fichier
    Dim sfi As SHFILEINFO
    If SHGetFileInfo(pszPath & Chr(0), 0, sfi, Len(sfi), SHGFI_SYSICONINDEX Or SHGFI_SMALLICON) Then
        GetSmallIconIndex = sfi.iIcon
    End If
End Function

Public Function GetFolder(ByVal hWndModal As Long) As String
' Cette procédure affiche une fenêtre de dialogue qui demande à l'utilisateur
' de choisir un répertoire
    Dim bInf As BROWSEINFO
    Dim RetVal As Long
    Dim PathID As Long
    Dim RetPath As String
    Dim Offset As Integer
    ' Détermine les propriétés de la fenêtre du dialogue
    bInf.hOwner = hWndModal
    bInf.lpszTitle = "Please select a folder:"
    bInf.ulFlags = BIF_RETURNONLYFSDIRS
    PathID = SHBrowseForFolder(bInf)
    RetPath = Space$(512)
    RetVal = SHGetPathFromIDList(ByVal PathID, ByVal RetPath)
    If RetVal Then
        ' On enlève les caractères nuls en fin de chaîne
        Offset = InStr(RetPath, Chr$(0))
        GetFolder = Left$(RetPath, Offset - 1)
        ' On libère la mémoire allouée à PIDL
        CoTaskMemFree PathID
    Else
        GetFolder = ""
    End If
End Function
Form1 - Code

Option Explicit
Dim DirLocal As String
Dim XS As Single, YS As Single

'  DÉTERMINATION D'UN RÉPERTOIRE ET CHARGEMENT DU LISTVIEW

Private Sub Cmd1_Click()

Dim NameFile As String
Dim rc As Long

' ======================================================
' On demande le répertoire
' ======================================================
    DirLocal = GetFolder(hWnd)
    If DirLocal = "" Then Exit Sub
    ' On enlève "\" s'il y en a un à la fin
    If Right(DirLocal, 1) = "\" Then DirLocal = Left(DirLocal, Len(DirLocal) - 1)

' ==========================================================
' Les ImagesLists du système
' ==========================================================
Dim himlSmall As Long
Dim himlLarge As Long
Dim sfi As SHFILEINFO
 ' Récupère les handles des ListesImages d'icônes du système
    himlSmall = SHGetFileInfo("C:\" & Chr(0), 0, sfi, Len(sfi), SHGFI_SYSICONINDEX Or SHGFI_SMALLICON)
    himlLarge = SHGetFileInfo("C:\" & Chr(0), 0, sfi, Len(sfi), SHGFI_SYSICONINDEX Or LVSIL_NORMAL)
    If (himlSmall <> 0 And himlLarge <> 0) Then
        rc = SendMessage(LV1.hWnd, LVM_SETIMAGELIST, ByVal LVSIL_SMALL, ByVal himlSmall)
        rc = SendMessage(LV1.hWnd, LVM_SETIMAGELIST, ByVal LVSIL_NORMAL, ByVal himlLarge)
    End If
' ==========================================================
Dim lvi As LV_ITEM
Dim iItem As Long ' (attention : cet index commence à partir de 0)

    LV1.ListItems.Clear
    LV1.View = lvwList
    iItem = 0
    LV1.Sorted = True
    lvi.mask = LVIF_IMAGE
    lvi.iSubItem = 0
    lvi.state = 0

On Error Resume Next ' (cas où lecteur indisponible)
If Dir(DirLocal, vbDirectory) <> "" Then
        If Err <> 0 Then
            MsgBox "Le dossier " & DirLocal & " n'est pas accessible" & vbLf & _
            Err.Description
            Err.Clear
            On Error GoTo 0
            Exit Sub
        End If
        NameFile = Dir(DirLocal & "\*.*", vbNormal Or vbHidden)
        On Error GoTo 0

        While Not NameFile = ""
        If NameFile <> "." And NameFile <> ".." Then
            With lvi
                .iItem = iItem
                .iImage = GetSmallIconIndex(DirLocal & "\" & NameFile & Chr(0))
            End With
            ' Attention : l'index ici commence à partir de 1
            LV1.ListItems.Add iItem + 1, DirLocal & "\" & NameFile, NameFile

            ' On remarque que les propriétés LV1.Icons et LV1.SmallIcons ne sont pas définies
            ' C'est à dire qu'il n'y a pas d'ImageList associée au contrôle LV1
            ' On va donc définir l'icône du fichier en envoyant un message à LV1 
            rc = SendMessage(LV1.hWnd, LVM_SETITEM, 0, lvi)
            NameFile = Dir()
            iItem = iItem + 1
        End If
    Wend
End If

Set LV1.SelectedItem = Nothing

' Nombre de fichiers trouvés
rc = SendMessage(LV1.hWnd, LVM_GETITEMCOUNT, 0, 0)
LblCount = CStr(rc) & " fichiers trouvés"
LblTitre = "Contenu de " & DirLocal

End Sub

' LANCEMENT DE L'APPLI ASSOCIÉE APRÈS DBLE-CLIC

Private Sub LV1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    ' On a besoin des valeurs publiques suivantes lors du double-clic
    XS = x
    YS = y
End Sub

Private Sub LV1_DblClick()
    ' Si on dble-clique en dehors d'un item, on annule
    On Error Resume Next
    Dim PLOP As Long
    PLOP = LV1.HitTest(XS, YS).Index
    If Err Then
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0

' On a double-cliqué, on lance l'appli par défaut pour ce fichier
Dim SEI As SHELLEXECUTEINFO
Dim rc As Long

With SEI
    .cbSize = Len(SEI)
    .fMask = 0&
    .hWnd = hWnd
    .nShow = SW_SHOWNORMAL
    .hInstApp = App.hInstance
    .lpFile = LV1.SelectedItem.Key & Chr(0)
    .lpDirectory = DirLocal & Chr(0)
End With

If (ShellExecuteEx(SEI) = 0) Then
    MsgBox "ShellExecuteEx failure"
End If

End Sub

' CHANGEMENT D'AFFICHAGE DES ICÔNES

Private Sub CmdView_Click(Index As Integer)
    Select Case Index
        Case 0 ' (petites icônes)
                LV1.View = lvwList
        Case 1 ' (grandes icônes)
                LV1.View = lvwIcon
        End Select
End Sub

Retour à l'accueil