Fortschrittsanzeige
19.06.2007 08:06:16
pain007
Ich habe ein Programm aus mehreren bereits bestehenden Quellcodes "zusammengebastelt", welches Dateien eines gewählten Ordner ausliest und diese nach Namen, Speicherort, Hyperlink usw. auflistet.
Da es bei manchen Einlesevorgängen sehr lange dauert wäre eine Fortschrittsbalken von Vorteil.
Leider habe ich sehr, sehr wenig Ahnung im VBA. Vielleicht könnt Ihr mir ja helfen diesen Balken einzubauen.
Hier der Quellcode:
Dim n
Dim dname(65000)
Dim dordner(65000)
Dim dcreated(65000)
Dim dpfad(65000)
Dim dlast(65000)
Dim dsize(65000)
Sub NeuEinlesen()
Set MyShell = CreateObject("wscript.shell")
Set MyFiles = CreateObject("Scripting.FileSystemObject")
Set Appshell = CreateObject("Shell.Application")
On Error Resume Next
Set AppFolder = Appshell.BrowseForFolder(0, "", &H1, 17)
verz = AppFolder.ParentFolder.ParseName(AppFolder.Title).Path
If Err.Number > 0 Then
i = InStr(AppFolder, ":")
verz = Mid(AppFolder, i - 1, 1) & ":\"
End If
If verz = "" Then Exit Sub
If n = 0 Then
Range("A3").Select
Range(Selection, Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
End If
Set drive = MyFiles.GetFolder(verz)
Set dat = drive.Files
For Each datei In dat
n = n + 1
dname(n) = datei.Name
dordner(n) = drive.Path
dpfad(n) = datei.Path
dsize(n) = datei.Size
dcreated(n) = datei.datecreated
dlast(n) = datei.DateLastAccessed
Next
Search drive
For x = 1 To n
Cells(x + 2, 1).Value = MyFiles.GetBaseName(dpfad(x))
Cells(x + 2, 2).Value = MyFiles.GetExtensionName(dpfad(x))
Cells(x + 2, 4).Value = dordner(x)
Cells(x + 2, 5).Value = Int(dsize(x) / 1024)
Cells(x + 2, 6).Value = DateValue(Date) - DateValue(dcreated(x))
Cells(x + 2, 7).Value = DateValue(Date) - DateValue(dlast(x))
Cells(x + 2, 8).Value = dpfad(x)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(x + 2, 9), Address:= _
dpfad(x), TextToDisplay:=dname(x)
Next
Application.ScreenUpdating = True
m = MsgBox(n & " Dateien eingetragen." & Chr(13) & "Weitere Daten hinzufügen?", 4)
If m = 6 Then NeuEinlesen
Range("A3").Select
Range(Selection, Cells.SpecialCells(xlCellTypeLastCell)).Select
Selection.Sort key1:=Range("D3"), order1:=xlAscending, Key2:=Range("A3") _
, Order2:=xlAscending, header:=xlNo
Range("A2:I2").Select
With Worksheets("Tabelle1")
If Not .AutoFilterMode Then
Selection.AutoFilter
End If
End With
Range("A2").Select
n = 0
End Sub
Sub Search(ByVal StartFolder)
Set Weitere = StartFolder.SubFolders
For Each AktuellerOrdner In Weitere
Set dat = AktuellerOrdner.Files
For Each datei In dat
n = n + 1
dname(n) = datei.Name
dordner(n) = AktuellerOrdner.Path
dpfad(n) = datei.Path
dsize(n) = datei.Size
dcreated(n) = datei.datecreated
dlast(n) = datei.DateLastAccessed
Next
Search AktuellerOrdner
Next
End Sub
Ich bedanke mich für Eure Hilfe vielmals im Voraus,
mfg pain007