XL 2019 Gestion des fichiers et répertoires

Sub CapaciteLecteur()


    ' Afficher la Capacité de chaque Lecteur ainsi que la lettre du Lecteur
  
    Dim GestionFichier As New Scripting.FileSystemObject
        ' On déclare une Variable de Type Objet qui représente un Lecteur
        Dim Lecteur As Object
            ' Pour "For" Chaque "Each" Lecteur dans le PC "Drives"
            For Each Lecteur In GestionFichier.Drives
                ' On affiche la Propriété "TotalSize" Capacité du Lecteur
                MsgBox Lecteur.DriveLetter & " = " & Lecteur.TotalSize
            Next
    Set GestionFichier = Nothing
  
End Sub

Option Explicit

Sub CapaciteLecteur()
Dim FSO As Object, sStr As String
Dim Lecteur As Object
    sStr = ""
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Lecteur In FSO.Drives
        On Error Resume Next
        sStr = sStr & Lecteur.DriveLetter & " = " & Format(Lecteur.TotalSize, "#,##0") & vbCrLf
    Next Lecteur
    Set FSO = Nothing
    MsgBox sStr, vbOKOnly + vbInformation, "Taille Lecteurs :"
End Sub

Option Explicit

Sub CapaciteLecteur()
Dim FSO As Object, sStr As String
Dim Lecteur As Object
    sStr = ""
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Lecteur In FSO.Drives
        On Error Resume Next
        sStr = sStr & Lecteur.DriveLetter & " = " & Unite(Lecteur.TotalSize) & vbCrLf
    Next Lecteur
    Set FSO = Nothing
    MsgBox sStr, vbOKOnly + vbInformation, "Taille Lecteurs :"
End Sub

Private Function Unite(ByVal Taille As Double) As String
Dim TabUnite As Variant
Dim i As Long

    i = 0
    TabUnite = Array("Octets", "Ko", "Mo", "Go", "To")
    Do While Taille >= 1024 And i < 4
        Taille = Taille / 1024
        i = i + 1
    Loop

    Unite = Round(Taille, 2) & " " & TabUnite(i)
End Function

Sub recherche_lecteurs_SurFeuille()
'code adapté par MJ issu de http://www.excel-downloads.com/forum/14470-trouver-un-fichier-sur-le-pc.html
Derl = Range("K65536").End(xlUp).Rows.Row
Range("K2:L" & Derl).Select
Selection.ClearContents
Dim Fso As Object
Dim Drv As Object
Dim Msg$
Range("K2").Select
Set Fso = CreateObject("Scripting.FileSystemObject")
Msg = "Votre système a " & Fso.drives.Count & " lecteurs :" & vbLf & vbLf
For Each Drv In Fso.drives
With Drv
'Stop
Select Case .DriveType
Case 0 ' unknown
Msg = Msg & "Lecteur: " & .DriveLetter & " est de type inconnu." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "type inconnu"
 ActiveCell.Offset(1, -1).Range("A1").Select
Case 1 ' removable, e.g., zip
Msg = Msg & "Lecteur: " & .DriveLetter & " est un disque amovible." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "disque amovible"
 ActiveCell.Offset(1, -1).Range("A1").Select
Case 2 ' fixed, hard drive
Msg = Msg & "Lecteur: " & .DriveLetter & " est un disque dur." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "disque dur"
 ActiveCell.Offset(1, -1).Range("A1").Select
Case 3 ' remote
Msg = Msg & "Lecteur: " & .DriveLetter & " est un disque réseau." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "disque réseau"
 ActiveCell.Offset(1, -1).Range("A1").Select
Case 4 ' CDROM
Msg = Msg & "Lecteur: " & .DriveLetter & " est un CDROM." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "CDROM"
 ActiveCell.Offset(1, -1).Range("A1").Select
Case 5 ' ram disk
Msg = Msg & "Lecteur: " & .DriveLetter & " est un disque virtuel." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "disque virtuel"
 ActiveCell.Offset(1, -1).Range("A1").Select
End Select
End With
Next Drv
Cells(2, 1).Select
'MsgBox Msg, , "Lecteurs du système"
End Sub

Sub Trouve_CléUSB()
Dim Fso As Object
Dim Drv As Object
Dim Msg$
Set Fso = CreateObject("Scripting.FileSystemObject")
'MsgBox ("Votre système a " & FSO.drives.Count & " lecteurs :" & vbLf & vbLf)
For Each Drv In Fso.drives
If Drv.DriveType = 1 Then MsgBox (Drv & " est un Disque amovible")
Next

End Sub

Sub ShowDriveletter_C_D()
drvPath = ActiveWorkbook.Path
ShowDriveletter (drvPath)
ShowDriveletter ("D:\")
End Sub
Sub ShowDriveletter(drvPath)
    Dim fs, d, s
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set d = fs.GetDrive(fs.GetDriveName(drvPath))
    s = "Drive " & d.DriveLetter & ": - "
    s = s & d.VolumeName & vbCrLf
    s = s & "Free Space: " & FormatNumber(d.FreeSpace / 1024, 0)
    s = s & " Kbytes"
    MsgBox s
End Sub