Sub Lire1
Dim objFSO, XDrive, XLetter, XName, XTotal, XFreeSpace, XType, XExist
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each XDrive In objFSO.Drives
XFreeSpace = 0: XGO = 0
If objFSO.DriveExists(XDrive) Then
XLetter = XDrive.DriveLetter:
XExist = objFSO.DriveExists(XDrive)
XType = XDrive.DriveType
' Type 1= CléUSB, 2= D.Dur, 4=Lecteur DVD
If XType <> 4 Then
XFreeSpace = XDrive.FreeSpace
XTotal = XDrive.totalSize
End If
End If
' afficher réponses
Next : Set objFSO = Nothing: End Sub
Sub Lire2
Dim objWMIService, objItem, colItems, Cpt, X$, y$, L$, L1$
Dim nom, model, size, NbPart, totCyl, TrakCyl
Dim TotHead, TotSect, SectTrak, TotTrak, BitSect
Cpt = ".": 'i = 3
Set objWMIService = GetObject("winmgmts:\\" & Cpt & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_DiskDrive")
For Each objItem In colItems
nom = objItem.Name
model = objItem.model
size = Int(objItem.size / (1073741824))
NbPart = objItem.Partitions
totCyl = objItem.TotalCylinders
TrakCyl = objItem.TracksPerCylinder
TotHead = objItem.TotalHeads
TotSect = objItem.TotalSectors
BitSect = objItem.BytesPerSector
SectTrak = objItem.SectorsPerTrack
TotTrak = objItem.TotalTracks
' afficher réponses
Next : Set objWMIService = Nothing : End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questiondim aff strComputer = "." Set objWMIService = GetObject("winmgmts:" _ & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2") Set colDisks = objWMIService.ExecQuery _ ("Select * from Win32_LogicalDisk") For each objDisk in colDisks aff = "Compressed: " & vbTab & objDisk.Compressed & vbcrlf aff = aff & "Description: " & vbTab & objDisk.Description & vbcrlf aff = aff & "DeviceID: " & vbTab & objDisk.DeviceID & vbcrlf aff = aff & "DriveType: " & vbTab & objDisk.DriveType & vbcrlf aff = aff & "FileSystem: " & vbTab & objDisk.FileSystem & vbcrlf aff = aff & "FreeSpace: " & vbTab & objDisk.FreeSpace & vbcrlf aff = aff & "MediaType: " & vbTab & objDisk.MediaType & vbcrlf aff = aff & "Name: " & vbTab & objDisk.Name & vbcrlf aff = aff & "QuotasDisabled: " & vbTab & objDisk.QuotasDisabled & vbcrlf aff = aff & "QuotasIncomplete: " & vbTab & objDisk.QuotasIncomplete & vbcrlf aff = aff & "QuotasRebuilding: " & vbTab & objDisk.QuotasRebuilding & vbcrlf aff = aff & "Size: " & vbTab & objDisk.Size & vbcrlf aff = aff & "SupportsDiskQuotas: " & vbTab & objDisk.SupportsDiskQuotas & vbcrlf aff = aff & "SupportsFileBasedCompression: " & vbTab _ & objDisk.SupportsFileBasedCompression & vbcrlf aff = aff & "SystemName: " & vbTab & objDisk.SystemName & vbcrlf aff = aff & "VolumeDirty: " & vbTab & objDisk.VolumeDirty & vbcrlf aff = aff & "VolumeName: " & vbTab & objDisk.VolumeName & vbcrlf aff = aff & "VolumeSerialNumber: " & vbTab & objDisk.VolumeSerialNumber MsgBox aff, vbInformation Next
Option Explicit 'http://vb.developpez.com/faq/vbs?page=Acces-aux-Dossiers-Repertoires#Comment-obtenir-des-informations-sur-un-dossier Private Sub CommandButton1_Click() Dim stRep 'Nom du répertoire à parcourir Dim oFSO, oFld Set oFSO = CreateObject("Scripting.FileSystemObject") stRep = "C:\Users\....\Documents\" 'a adapter If oFSO.FolderExists(stRep) Then Set oFld = oFSO.GetFolder(stRep) MsgBox "Attributes :" & oFld.Attributes & vbCrLf & _ "DateCreated :" & oFld.DateCreated & vbCrLf & _ "DateLastAccessed :" & oFld.DateLastAccessed & vbCrLf & _ "DateLastModified :" & oFld.DateLastModified & vbCrLf & _ "Drive :" & oFld.Drive & vbCrLf & _ "IsRootFolder :" & oFld.IsRootFolder & vbCrLf & _ "Name :" & oFld.Name & vbCrLf & _ "ParentFolder :" & oFld.ParentFolder & vbCrLf & _ "Path :" & oFld.Path & vbCrLf & _ "ShortName :" & oFld.ShortName & vbCrLf & _ "ShortPath :" & oFld.ShortPath & vbCrLf & _ "Size :" & oFld.Size & vbCrLf & _ "SubFolders.Count :" & oFld.SubFolders.Count & vbCrLf & _ "Type :" & oFld.Type End If End Sub
Sheets(feuil).Activate: Sheets(feuil).Delete
Option Explicit Private Sub CommandButton1_Click() AfficheContenuVolume ("C:\Users\Daniel\Documents\") End Sub Sub AfficheContenuVolume(ChDoss$) Dim fs, f, f1, fc, sf, i%, x$, Att, Sw As Boolean ' ObjCaché est un boolean validant(ou non) Dim ObjCaché i = 2 ' l'exploitation des documents cachés 1: Set fs = CreateObject("Scripting.FileSystemObject") If Dir(ChDoss$, vbDirectory) = vbNullString Then Exit Sub Set f = fs.getFolder(ChDoss): Set sf = f.SubFolders For Each f1 In sf: Att = f1.Attributes: Sw = Att And 6 And ObjCaché: If Sw Then GoTo Nx1 x = "A" + Trim(i): Range(x).Value = f1.Name: Range(x).Font.Bold = True If Att And 4 Then Range(x).Font.Color = vbRed Else If Att And 2 Then Range(x).Font.Color = vbBlue x = "B" + Trim(i): Range(x).Value = Format(f1.DateCreated, "dd/mm/yyyy") x = "C" + Trim(i): Range(x).Value = Format(f1.DateLastModified, "dd/mm/yyyy") x = "D" + Trim(i): Range(x).Value = "D": i = i + 1 Nx1: Next: i = i + 1: Set fs = Nothing Set fs = CreateObject("Scripting.FileSystemObject"): Set fc = f.Files For Each f1 In fc: Att = f1.Attributes: Sw = Att And 6 And ObjCaché: If Sw Then GoTo Nx2 x = "A" + Trim(i): Range(x).Value = f1.Name: Range(x).Font.Bold = False If Att And 4 Then Range(x).Font.Color = vbRed Else If Att And 2 Then Range(x).Font.Color = vbBlue x = "B" + Trim(i): Range(x).Value = Format(f1.DateCreated, "dd/mm/yyyy") x = "C" + Trim(i): Range(x).Value = Format(f1.DateLastModified, "dd/mm/yyyy"): i = i + 1 Columns("A:C").EntireColumn.AutoFit Nx2: Next: Set fs = Nothing: End Sub
Private Sub CommandButton2_Click() AfficheContenuVolumeLePivert ("H\:Films\") AfficheContenuVolumeLePivert ("C\:Comptes\") AfficheContenuVolumeLePivert ("K\:Mes sources VB6\Anniversaires\") AfficheContenuVolumeLePivert ("C\:Comptes\") AfficheContenuVolumeLePivert ("H\:fotos\charlène\") AfficheContenuVolumeLePivert ("I\:opérations sur films\") AfficheContenuVolumeLePivert ("D\:jeux\lp sudoku\") End Sub Sub AfficheContenuVolumeLePivert(ByRef stRep$) 'Dim stRep 'Nom du répertoire à parcourir Dim oFSO, oFld Set oFSO = CreateObject("Scripting.FileSystemObject") ' stRep = "H\:fotos\charlène\" 'a adapter Debug.Print stRep, oFSO.FolderExists(stRep) ' indique Faux pour tous les appels If Not oFSO.FolderExists(stRep) Then Exit Sub Set oFld = oFSO.GetFolder(stRep) MsgBox "Attributes :" & oFld.Attributes & vbCrLf & _ "DateCreated :" & oFld.DateCreated & vbCrLf & _ "DateLastAccessed :" & oFld.DateLastAccessed & vbCrLf & _ "DateLastModified :" & oFld.DateLastModified & vbCrLf & _ "Drive :" & oFld.Drive & vbCrLf & _ "IsRootFolder :" & oFld.IsRootFolder & vbCrLf & _ "Name :" & oFld.Name & vbCrLf & _ "ParentFolder :" & oFld.ParentFolder & vbCrLf & _ "Path :" & oFld.Path & vbCrLf & _ "ShortName :" & oFld.ShortName & vbCrLf & _ "ShortPath :" & oFld.ShortPath & vbCrLf & _ "Size :" & oFld.size & vbCrLf & _ "SubFolders.Count :" & oFld.SubFolders.Count & vbCrLf & _ "Type :" & oFld.Type ' End If End Sub
"Size :" & oFld.size
Sub AfficheContenuVolumeLePivert(ByRef stRep$) 'Dim stRep 'Nom du répertoire à parcourir Dim oFSO, oFld Set oFSO = CreateObject("Scripting.FileSystemObject") ' stRep = "H\:fotos\charlène\" 'a adapter Debug.Print stRep, oFSO.FolderExists(stRep) ' indique Faux pour tous les appels If Not oFSO.FolderExists(stRep) Then Exit Sub Set oFld = oFSO.GetFolder(stRep) MsgBox "Attributes :" & oFld.Attributes & vbCrLf & _ "DateCreated :" & oFld.DateCreated & vbCrLf & _ "DateLastAccessed :" & oFld.DateLastAccessed & vbCrLf & _ "DateLastModified :" & oFld.DateLastModified & vbCrLf & _ "Drive :" & oFld.Drive & vbCrLf & _ "IsRootFolder :" & oFld.IsRootFolder & vbCrLf & _ "Name :" & oFld.Name & vbCrLf & _ "ParentFolder :" & oFld.ParentFolder & vbCrLf & _ "Path :" & oFld.Path & vbCrLf & _ "ShortName :" & oFld.ShortName & vbCrLf & _ "ShortPath :" & oFld.ShortPath & vbCrLf & _ "SubFolders.Count :" & oFld.SubFolders.Count & vbCrLf & _ "Type :" & oFld.Type End Sub
Private Sub CommandButton2_Click()
AfficheContenuVolumeLePivert ("H\:Films\")
AfficheContenuVolumeLePivert ("C\:Comptes\")
AfficheContenuVolumeLePivert ("K\:Mes sources VB6\Anniversaires\")
AfficheContenuVolumeLePivert ("C\:Comptes\")
AfficheContenuVolumeLePivert ("H\:fotos\charlène\")
AfficheContenuVolumeLePivert ("I\:opérations sur films\")
AfficheContenuVolumeLePivert ("D\:jeux\lp sudoku\")
End Sub
Sub AfficheContenuVolumeLePivert(ByRef stRep$)
Dim oFSO, oFld
On Error GoTo ER
Set oFSO = CreateObject("Scripting.FileSystemObject")
Debug.Print stRep, oFSO.FolderExists(stRep) ' indique Faux pour tous les appels
' If Not oFSO.FolderExists(stRep) Then Exit Sub
Set oFld = oFSO.GetFolder(stRep) ' indique err=76, Chemin d'accès introuvable
MsgBox "Attributes :" & oFld.Attributes & vbCrLf & _
"DateCreated :" & oFld.DateCreated & vbCrLf & _
"DateLastAccessed :" & oFld.DateLastAccessed & vbCrLf & _
"DateLastModified :" & oFld.DateLastModified & vbCrLf & _
"Drive :" & oFld.Drive & vbCrLf & _
"IsRootFolder :" & oFld.IsRootFolder & vbCrLf & _
"Name :" & oFld.Name & vbCrLf & _
"ParentFolder :" & oFld.ParentFolder & vbCrLf & _
"Path :" & oFld.Path & vbCrLf & _
"ShortName :" & oFld.ShortName & vbCrLf & _
"ShortPath :" & oFld.ShortPath & vbCrLf & _
"SubFolders.Count :" & oFld.SubFolders.Count & vbCrLf & _
"Type :" & oFld.Type
GoTo 9
ER: Debug.Print Err, Error: Resume 9
9: On Error GoTo 0
End Sub
AfficheContenuVolumeLePivert ("H\:Films\") AfficheContenuVolumeLePivert ("C\:Comptes\") AfficheContenuVolumeLePivert ("K\:Mes sources VB6\Anniversaires\") AfficheContenuVolumeLePivert ("C\:Comptes\") AfficheContenuVolumeLePivert ("H\:fotos\charlène\") AfficheContenuVolumeLePivert ("I\:opérations sur films\") AfficheContenuVolumeLePivert ("D\:jeux\lp sudoku\")
Dim Fichier As Variant 'Affichage de la la boîte de dialogue standard "Ouvrir" pour sélectionner un fichier 'sur le disque dur. 'GetOpenFilename permet de lire le nom du fichier sélectionné par l'utilisateur sans 'réellement ouvrir le fichier. Fichier = Application.GetOpenFilename("Fichiers (*.*),*.*") [A1] = Fichier 'inscrire le chemin du fichier sur la feuille 1 'Vérifie si l'utilisateur a cliqué sur le bouton "Annuler" ou sur la croix de fermeture. If Fichier = False Then MsgBox "Opération Annulée" 'pour sortir de la procédure Exit Sub End If