Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Laufwerksgröße | Herbers Excel-Forum


Betrifft: Laufwerksgröße von: Georg
Geschrieben am: 23.10.2008 14:54:34

Hallo Excelwelt,
kann ich per Makro mir die Größe und Bezeichnungen aller verschiedenen Pfade auf einem zu definierenden Laufwerk ermitteln und in einer Excel Datei ausgeben lassen?
Oder bin ich damit hier bei der falschen Fraktion mit dem Ansinnen?
Wer könnte mir sonst weiterhelfen?
Danke und Gruß Georg

  

Betrifft: AW: Laufwerksgröße von: Kawensmann
Geschrieben am: 23.10.2008 15:45:43

Hallo,

guck mal hier:

http://vba1.de/vba/097laufwerke.php

Gruß

Kawensmann


  

Betrifft: AW: Laufwerksgröße von: Georg
Geschrieben am: 23.10.2008 15:51:17

Danke Kawensmann, aber ich will die Struktur im Laufwerk erkennen. Will sagen: ich will als Ergebniss eine Liste haben, die mir alle verschiedenen Pfade mit der jeweiligen Größe auswirft.

D:\TSI\Berichte\Daten\2008\KW 41 150 MB
D:\TSI\Berichte\Daten\2008\KW 42 180 MB
D:\TSI\Berichte\Daten\2008\KW 43 160 MB

o.s.ä.

Geht das? Danke
Georg


  

Betrifft: AW: Laufwerksgröße von: Anton
Geschrieben am: 23.10.2008 23:12:12

Hallo,

noch eine Variante:

Sub b()
  Dim AppShell As Object, fso As Object  
  Dim Pfad As String, i As Double, o, BrowseDir    
  Set AppShell = CreateObject("Shell.Application")  
  Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)  
  If BrowseDir Is Nothing Then Exit Sub      
  Pfad = BrowseDir.items().Item().Path
  On Error Resume Next    
  Cells.Clear
  Cells(1, 1) = "Ordner"
  Cells(1, 2) = "Grösse in MB"
  i = 2
  Set fso = CreateObject("Scripting.FileSystemObject")  
  For Each o In fso.GetFolder(Pfad).SubFolders    
    Cells(i, 1) = o: Cells(i, 2) = Round(o.Size / 1024 / 1024, 2) & " MB."
    i = i + 1
  Next
  Columns.AutoFit
  Columns(2).HorizontalAlignment = xlRight
End Sub  


mfg Anton


  

Betrifft: AW: Laufwerksgröße von: Tino
Geschrieben am: 23.10.2008 15:51:03

Hallo,
hilft Dir dies weiter?

Option Explicit

Sub test()
Dim fs As Object, driv As Object
Dim liste As String
Set fs = CreateObject("Scripting.filesystemobject")
Set driv = fs.drives("c:")
'On Error Resume Next 
liste = "Laufwerk bereit?: " & driv.isready & vbCr
liste = liste & "Laufwerkname: " & driv.volumename & vbCr
liste = liste & "Laufwerkbuchstabe: " & driv.driveletter & vbCr
liste = liste & "Seriennummer: " & driv.serialnumber & vbCr
liste = liste & "Gesamterplatz: " & BerecheMByte(driv.totalsize) & " MegaByte" & vbCr
liste = liste & "verfügbarer Platz: " & BerecheMByte(driv.availablespace) & " MegaByte" & vbCr
liste = liste & "Path Name: " & driv.Path & vbCr
liste = liste & "root: " & driv.rootfolder & vbCr
liste = liste & "Dateisystem: " & driv.FileSystem & vbCr
liste = liste & "Typ: " & LType(driv.drivetype)
MsgBox liste



End Sub
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


  

Betrifft: AW: Laufwerksgröße von: Georg
Geschrieben am: 23.10.2008 15:55:18

Danke auch Dir, Tino, aber ich hätte halt gerne eine Liste, wie eben gepostet!


  

Betrifft: noch eine Version von: Tino
Geschrieben am: 23.10.2008 18:09:01

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


  

Betrifft: Antwort an Tino und Anton von: Georg
Geschrieben am: 24.10.2008 11:08:31

Hallo Tino und Anton,

ich hab die mir erlaubt Eure Codes zu kombinieren und es klappt prima. Vielen Dank Euch beiden!!

Georg

PS: es sieht jetzt so aus:


Option Explicit
Dim Liste As String

Sub Ordner()
Dim varListe
Dim i As Long
Dim B As Long
 
Application.ScreenUpdating = False
Cells.ClearContents
Range("A1") = "Pfad"
Range("B1") = "Volume File"
 
Liste = ""
Listordner "C:\"
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)))
 B = B + 1
Next i
    Liste = ""
    Erase varListe
Columns.AutoFit
Application.ScreenUpdating = True
End Sub




Sub Listordner(Ordner)
Dim FS As Object
Dim File As Object
Dim 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 = Round(FS.Size / 1024 / 1024, 2)
    Exit Function
Fehler:
AnzahlFile = "Zugriff verweigert"
End Function




  

Betrifft: AW: Laufwerksgröße von: fcs
Geschrieben am: 23.10.2008 17:35:48

Hallo Georg,

bei sehr vielen Dateien ist meine Lösung ziemlich langsam, da die Dateigrößen der Dateien in den Ordnern einzeln abgefragt und addiert werden.

Also erst einmal eine Ordner mit wenigen Unterordnern/dateien zum probieren wählen.
Das Makro legt jeweils ein neues Tabellenblatt für die Liste an.

Gruß
Franz

Public Sub Ordner_Auflisten3()
    Dim OrdnerName As Variant, varAuswahl
    Application.ScreenUpdating = False
    Set FSO = CreateObject("Scripting.FileSystemObject")
    ActiveWorkbook.Worksheets.Add 'leeres Tabellenblatt für Liste einfügen
    icol = 1
    lRow = 1
    Cells(lRow, icol) = "Verzeichnis"
    Cells(lRow, icol + 1) = "Leseberechtigung"
    Cells(lRow, icol + 2) = "Anzahl Dateien"
    Cells(lRow, icol + 3) = "MByte"
    lRow = lRow + 1
    varAuswahl = Application.GetOpenFilename(Filefilter:="Alle(*.*),*.*", _
        Title:="Zur Ordnerauswahl bitte Datei im gewünschten Ordner wählen oder abbrechen")
    OrdnerName = VBA.CurDir
    Cells(lRow, icol) = OrdnerName
    GetSubFolders3 OrdnerName
    Columns(4).NumberFormat = "#,##0.000000"
    Columns.AutoFit
    Range("A2").Select
    ActiveWindow.FreezePanes = True
    Application.ScreenUpdating = True
    MsgBox "Fertig"
End Sub

Function GetSubFolders3(Pfad)
  Dim objFilesearch As FileSearch, dblSummeDateigroesse As Double, intI As Integer
  Set FO = FSO.GetFolder(Pfad)
  Set FU = FO.SubFolders
  On Error GoTo fehler
  For Each F In FU
    lRow = lRow + 1
    Cells(lRow, icol) = F
    Set objFilesearch = Application.FileSearch
    With objFilesearch
      .NewSearch
      .LookIn = F
      .SearchSubFolders = False
      .FileType = msoFileTypeAllFiles
      If .Execute > 0 Then
        'Anzahl Dateien im Ordner
        Cells(lRow, icol + 2) = .FoundFiles.Count
        'Summe der Größe aller Dateien
        dblSummeDateigroesse = 0
        For intI = 1 To .FoundFiles.Count
          dblSummeDateigroesse = dblSummeDateigroesse + VBA.FileLen(.FoundFiles(intI))
        Next
        Cells(lRow, icol + 3) = dblSummeDateigroesse / 1024 ^ 2
      End If
    End With
    GetSubFolders3 F.Path
  Next
fehler:
  If Err.Number <> 0 Then
    If Err.Number = 70 Then
      Cells(lRow, icol + 1) = "Nein" 'keine Leseberechtigung für Ordner
    ElseIf Err.Number = 424 Then
'      Objekt fehlt, da keine Leseberechtigung
    Else
      MsgBox "Fehler Nr. " & Err.Number & vbLf & Err.Description
    End If
  End If
End Function




  

Betrifft: AW: Laufwerksgröße von: Georg
Geschrieben am: 23.10.2008 17:45:31

Hallo Franz,

geile Kiste, daß man sowas so schnell schreiben kann ?!?!?!

Leider bleibt er hängen bei:

Set FO = FSO.GetFolder(Pfad)

und sagt "Laufzeitfehler 424 Objekt erforderlich"

Was tun?
Danke Georg