Datum wird falsch angezeigt
19.06.2007 09:12:00
pain007
Sehr geehrter VBA und Excel Profis!
Ich habe noch ein Problem: 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.
Ich bräuchte nun damit ich die bestehende Dateiliste ständig aktualisieren kann auch das Entstehungsdatum der Datei. Dieses wird auch eingelesen (in Spalte F). Leider wird es aber nicht richtig anzeigt, es wird irgendein Datum im Jahre 1900 angezeigt, wenn ich Format-Zellen Datum einstelle, ansonsten wird nur eine zweistellige Zahl anzeigt. Bitte kann mir jemand helfen das Problem zu lösen?
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