noch eine Version
23.10.2008 18:09:00
Tino
Hallo,
hier noch eine Version.
Modul Modul2
Option Explicit
Dim Liste As String
Sub Ordner()
Dim varListe
Dim i As Long, B As Long
Application.ScreenUpdating = False
Cells.ClearContents
Range("A1") = "Pfad"
Range("B1") = "Anzahl File"
Range("C1") = "Laufwerk bereit"
Range("D1") = "Laufwerkname:"
Range("E1") = "Seriennummer:"
Range("F1") = "Gesamterplatz:"
Range("G1") = "verfügbarer Platz:"
Range("H1") = "Path Name:"
Range("I1") = "Dateisystem:"
Range("J1") = "Typ:"
Liste = ""
Listordner "E:\"
varListe = Split(Liste, "<")
B = 2 'erste Zeile
For i = 1 To Ubound(varListe)
Cells(B, "A") = varListe(i)
Cells(B, "B") = AnzahlFile(CStr(varListe(i)))
If Cells(B, "B") <> "Zugriff verweigert" Then
Range(Cells(B, "C"), Cells(B, "j")) = Split(Info(CStr(varListe(i))), "<")
End If
B = B + 1
Next i
Liste = ""
Erase varListe
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Sub Listordner(Ordner)
Dim FS As Object, File As Object, unterordner As Object
Dim i As Long
Set FS = CreateObject("Scripting.FileSystemObject")
Set Ordner = FS.getfolder(Ordner)
On Error GoTo Fehler:
For Each unterordner In Ordner.subfolders
Liste = Liste & "<" & unterordner
i = i + 1
Listordner (unterordner)
Next
Fehler:
On Error GoTo 0: Err.Number = 0
End Sub
Function AnzahlFile(sPfad As String)
Dim FS As Object
Set FS = CreateObject("Scripting.filesystemobject")
Set FS = FS.getfolder(sPfad)
On Error GoTo Fehler:
AnzahlFile = FS.Files.Count
Exit Function
Fehler:
AnzahlFile = "Zugriff verweigert"
End Function
Function Info(sPfad As String)
Dim FS As Object, driv As Object
Dim Liste As String
Set FS = CreateObject("Scripting.filesystemobject")
sPfad = Left$(sPfad, InStr(sPfad, "\"))
Set driv = FS.GetDrive(sPfad)
Liste = driv.isready & vbCr
Liste = Liste & "<" & driv.volumename & vbCr
Liste = Liste & "<" & driv.serialnumber & vbCr
Liste = Liste & "<" & BerecheMByte(driv.totalsize) & " MegaByte" & vbCr
Liste = Liste & "<" & BerecheMByte(driv.availablespace) & " MegaByte" & vbCr
Liste = Liste & "<" & driv.Path & vbCr
Liste = Liste & "<" & driv.FileSystem & vbCr
Liste = Liste & "<" & LType(driv.drivetype)
Info = Liste
Exit Function
Fehler:
End Function
Function LType(iTyp As Integer) As String
'Die Nummer beim Typ hat folgende Bedeutung:
Select Case iTyp
Case 0: LType = "unbekannt"
Case 1: LType = "Wechselmedium, Z.B.Zip - Drive"
Case 2: LType = "Festplatte"
Case 3: LType = "Netzwerk - Laufwerk"
Case 4: LType = "CD - ROM"
Case 5: LType = "RAM - Disk"
End Select
End Function
Function BerecheMByte(Wert As Double) As Double
Wert = Wert / 1024: Wert = Wert / 1024
BerecheMByte = Round(Wert, 2)
End Function
Gruß Tino