Explorateur de fichiers sous access

Télécharger le projet
Commenter

Description

Comme le titre l'indique, c'est un explorateur de fichiers sous access gérer par un treeview, un listview et une imageList. Ce programme permet de visualiser l'arborescence des fichiers de vos disques ainsi que de les lancer grâce à la lib ShellExecuteA.
Je n'ai pas intégré les lecteurs réseaux car si vous n'avez pas accès à certains répertoires, il y a une erreur qui se produit. Si vous êtes administrateur du réseau, vous n'avez qu'à enlever le "if (d.DriteType <> 3)" ... pour pouvoir les voir.

Source / Exemple : 


Option Compare Database
Dim LV1Path, rep, fic, FicOld As String
Dim Same As Boolean
Dim Ind As Integer

Private Sub Form_Load()
    Dim fs As Object
    Dim dc, d
    Dim str, n, img As String

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set dc = fs.Drives
    For Each d In dc
        If (d.IsReady) Then
            str = fs.GetDrive(d.Driveletter).RootFolder
        Else:
            GoTo suite2
        End If
        Select Case d.DriveType
            Case 0: n = "Inconnu"
            Case 1: n = "Amovible"
            Case 2:
                n = d.VolumeName
                img = "HDD"
            Case 3:
                n = d.ShareName
                img = "DR"
            Case 4:
                n = "CD-ROM"
                img = "CD"
            Case 5: n = "Disque RAM"
        End Select

        n = n & " (" & d.Driveletter & ":)"
        'Création des noeuds racines des disques)
        If (d.DriveType <> 3) Then
            Me.TV1.Nodes.Add , , str, n, img
            AjouteRep str
        End If
suite2:
    Next
End Sub

Private Sub AjouteRep(ByVal str As String, Optional ByRef Node As Object = Nothing)
    Dim fs, f, fld, fld1, sf
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(str)
    Set sf = f.SubFolders
    For Each fld In sf
        'Évite les répertoire qui font planter la fonction
        If fld.Name = "RECYCLER" Then GoTo suite
        If fld.Name = "System Volume Information" Then GoTo suite
        If fld.Name = "DO_NOT_REMOVE_NtFrs_PreInstall_Directory" Then GoTo suite
        'ajoute les dossier
        If f.IsRootFolder = True Then
            Me.TV1.Nodes.Add str, tvwChild, fld.Path, fld.Name, "Dossier"
            'Ajoute les sous dossiers
            AjouteRep fld.Path
         Else:
            Me.TV1.Nodes.Add str, tvwChild, fld.Path, fld.Name, "Dossier"
            AjouteRep fld.Path
         End If
suite:
    Next
End Sub

'Gestion des clics dans le TreeView
Private Sub TV1_NodeClick(ByVal Node As Object)
    Dim li As ListItem
    Dim li2 As ListItem
    Dim fld
    Dim fic, rep, img As String
    Dim f
    Dim fldl
    Dim message As Boolean 'sera utile pour filtrer des dossiers à ne pas afficher
    Dim fs As Object
    Dim a As Integer
    
    a = 2
    Ind = Node.Index
    Me.LV1.ListItems.Clear
    'construit le nom du répertoire
    While (Mid(Node.FullPath, a, 1) <> ":")
        a = a + 1
    Wend
    rep = Mid(Node.FullPath, a - 1, 2) & Mid(Node.FullPath, a + 2)
    'MsgBox rep
    If Right(rep, 1) <> "\" Then rep = rep & "\"
    LV1Path = rep
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fld = fs.GetFolder(rep)
    message = False
    
    'ajoute les éléments dossier a LV1 sans prendre en compte la poubelle et l'information de volume systeme.
    For Each fldl In fld.SubFolders
        If fldl.Name = "RECYCLER" Then message = True
        If fldl.Name = "System Volume Information" Then message = True
        'MsgBox fldl.Name
        If message = False Then
           Me.LV1.ListItems.Add , , fldl.Name, "Dossier", "Dossier"
            'li.ListSubItems.Add Key:="size", Text:=fldl.Size
            'li.ListSubItems.Add Key:="date", Text:=fldl.DateLastModified
        End If
    Next
    
    'ajouter les élément fichier a LV1
    For Each f In fld.Files
        'On affecte l'image en fonction du type du fichier
        img = FindImg(f.Name)
        Me.LV1.ListItems.Add , , f.Name, img, img
        'Me.LV1.ListSubItems.Add Key:="size", Text:=f.Size
        'li2.ListSubItems.Add Key:="date", Text:=f.DateLastModified
    Next
End Sub

'Gestion des clics dans la listeView
Private Sub LV1_ItemClick(ByVal Item As Object)
    Dim fs As Object
    Dim f, fldl, fld
    Dim message As Boolean

    'Construit le nom du répertoire
    GetRep Item 'donne rep, fic et LV1Path
    
    If Item.Icon <> "Dossier" Then
        MsgBox "Vous ne pouvez pas lancer les fichiers! :'("
        'If (Right(fic, 3) = "exe") Then
        '    Shell (rep), vbMaximizedFocus
        'End If
        Exit Sub 's'il ne sagit pas d'un dossier on sort de la sub
    End If
    
    'Récupération de l'index du node correspondant dans le treeview
    Ind = Me.TV1.Nodes(Ind).Child.FirstSibling.Index
    While Me.TV1.Nodes(Ind).Text <> Item.Text
          Ind = Me.TV1.Nodes(Ind).Next.Index
    Wend
    TV1_Expand (Me.TV1.Nodes(Ind))

    Me.LV1.ListItems.Clear
    
    'construit rep
    MsgBox rep
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fld = fs.GetFolder(rep)

    message = False
    'Ajoute les éléments dossier à LV1 sans prendre en compte la poubelle et l'information du volume systeme.
    For Each fldl In fld.SubFolders
        If fldl.Name = "RECYCLER" Then message = True
        If fldl.Name = "System Volume Information" Then message = True
        If message = False Then
            Me.LV1.ListItems.Add , , fldl.Name, "Dossier", "Dossier"
            'li.ListSubItems.Add Key:="size", Text:=fldl.Size
            'li.ListSubItems.Add Key:="date", Text:=fldl.DateLastModified
        End If
    Next
    
    'Ajouter les élément fichier à LV1
    For Each f In fld.Files
        img = FindImg(f.Name)
        Me.LV1.ListItems.Add , , f.Name, img, img
        'li2.ListSubItems.Add Key:="size", Text:=f.Size
        'li2.ListSubItems.Add Key:="date", Text:=f.DateLastModified
    Next

End Sub

Public Sub TV1_Expand(ByVal Node As Object)
    If (Node.Parent Is Nothing = False) Then 'S'il s'agit des lecteurs on ne change pas l'image
        Node.Image = "DossierOpen"
    End If
End Sub

Public Sub TV1_Collapse(ByVal Node As Object)
    If (Node.Parent Is Nothing = False) Then
        Node.Image = "Dossier"
    End If
End Sub

Private Function FindImg(str As String) As String
    Select Case Right(str, 3)
            Case Is = "txt": FindImg = "Txt"
            Case Is = "doc": FindImg = "Doc"
            Case Is = "zip": FindImg = "Zip"
            Case Is = "rar": FindImg = "Zip"
            Case Is = "exe": FindImg = "Exe"
            Case Is = "mdb": FindImg = "Mdb"
            Case Is = "xls": FindImg = "Xls"
            Case Is = "ppt": FindImg = "Ppt"
            Case Is = "tml": FindImg = "IE"
            Case Is = "htm": FindImg = "IE"
            Case Is = "wav": FindImg = "Mp3"
            Case Is = "mp3": FindImg = "Mp3"
            Case Is = "dll": FindImg = "Dll"
            Case Is = "ini": FindImg = "Ini"
            Case Is = "bmp": FindImg = "Img"
            Case Is = "jpg": FindImg = "Img"
            Case Is = "gif": FindImg = "Img"
            Case Else: FindImg = "Unk"
        End Select
End Function

Public Function GetRep(ByVal Item As Object) As String
    'Construction le nom du répertoire
    fic = Item.Text 'Nom du fichier cliqué
    rep = LV1Path
    If Right(rep, 1) <> "\" Then rep = rep & "\"
    rep = rep & fic
    LV1Path = rep
End Function

Conclusion :


Pas mal si on veut voir comment marche les TV et LV, mais il est plus simple de faire un activeX en VB à partir des DirListBox & cie et de les appliquer sous access...
De plus, ça ira plus vite qu'un Treeview...
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 (tbbuim1)