Supportnet / Forum / Skripte(PHP,ASP,Perl...)
DateModified als zusätzliche Spalte
Frage
Hallo an alle
Ich bin, was Makroprogrammierung angeht, völlig unwissend. Nun konnte ich ein Excel-Makro finden, das es mir ermöglicht, aus vielen Dateien den Namen, den Pfad, die Zeit seit Erstellung und seit letztem Zugriff und die Dateigröße auszulesen. Leider fehlt mir nun noch das Datum der letzten Änderung (DateModified). Ich wäre Euch sehr dankbar, wenn mir jemand die notwendigen Änderungen verraten könnte. Die Codes lauten:
***** DieseArbeitsmappe (Code) *****
Private Sub Workbook_Open()
Sheets("Tabelle1").OnDoubleClick = "DieseArbeitsmappe.StartIt"
End Sub
Sub StartIt()
Set MyShell = CreateObject("WScript.Shell")
spalte = ActiveCell.Column
zeile = ActiveCell.Row
If zeile = 1 Then Exit Sub
If spalte > 6 Then Exit Sub
If zeile = 2 Then
Cells(zeile, spalte).Select
If Selection.Interior.ColorIndex = 16 Then
Range("A2:F2").Select
Selection.Interior.ColorIndex = 16
Cells(zeile, spalte).Select
Selection.Interior.ColorIndex = 15
Range("A3").Select
Range(Selection, Cells.SpecialCells(xlCellTypeLastCell)).Select
If spalte = 2 Then
Selection.Sort Key1:=Range("B3"), Order1:=xlDescending, Key2:=Range("A3") _
, Order2:=xlAscending, Header:=xlNo
Else
Selection.Sort Key1:=Cells(zeile + 1, spalte), Order1:=xlDescending, Header:=xlNo
End If
Else
Range("A2:F2").Select
Selection.Interior.ColorIndex = 16
Cells(zeile, spalte).Select
Selection.Interior.ColorIndex = 16
Range("A3").Select
Range(Selection, Cells.SpecialCells(xlCellTypeLastCell)).Select
If spalte = 2 Then
Selection.Sort Key1:=Range("B3"), Order1:=xlAscending, Key2:=Range("A3") _
, Order2:=xlAscending, Header:=xlNo
Else
Selection.Sort Key1:=Cells(zeile + 1, spalte), Order1:=xlAscending, Header:=xlNo
End If
End If
Range("A2").Select
Exit Sub
End If
datei = Chr(34) & Cells(zeile, 6).Value & Chr(34)
On Error Resume Next
If spalte = 1 Then
If zeile > 2 Then MyShell.Run datei
End If
If spalte = 6 Then
MyShell.Run "explorer.exe /select," & datei
End If
If spalte = 2 Then
If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
Else
temp = "=" & Cells(zeile, spalte).Value
Range("A3").Select
Range(Selection, Cells.SpecialCells(xlCellTypeLastCell)).Select
Selection.AutoFilter Field:=spalte, Criteria1:=temp, Operator:=xlAnd
End If
End If
If spalte = 3 Or spalte = 4 Or spalte = 5 Then
ActiveSheet.ShowAllData
temp = Cells(zeile, spalte).Value
unten = ">" & temp - 1
oben = "<" & temp * 2 + 1
Range("A3").Select
Range(Selection, Cells.SpecialCells(xlCellTypeLastCell)).Select
Selection.AutoFilter Field:=spalte, Criteria1:=unten, Operator:=xlAnd, Criteria2:=oben
End If
Range("A2").Select
End Sub
***** Tabelle 1 (Code) *****
Private Sub CommandButton1_Click()
Set MyShell = CreateObject("WScript.Shell")
spalte = ActiveCell.Column
zeile = ActiveCell.Row
On Error Resume Next
If spalte = 1 And zeile > 2 Then
For Each zelle In Selection
zeile = zelle.Row
If Rows(zeile).Hidden = False Then
spalte = zelle.Column
datei = Cells(zeile, 6).Value
MyShell.Run Chr(34) & datei & Chr(34)
End If
Next
End If
End Sub
Private Sub CommandButton2_Click()
Call NeuEinlesen
End Sub
Private Sub CommandButton3_Click()
On Error Resume Next
ActiveSheet.ShowAllData
temp = InputBox("Einen oder zwei Begriffe eingeben (Logisches UND)." & Chr(13) & "Leerzeichen trennt zwei Strings." & Chr(13) & Chr(13) & "Beispiel: Brief 2002", "")
If temp = "" Then Exit Sub
Range("A3").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Selection
i = InStr(temp, " ")
If i = 0 Then
suche = "*" & temp & "*"
Selection.AutoFilter Field:=6, Criteria1:=suche, Operator:=xlAnd
Else
suche = "*" & Left(temp, i - 1) & "*"
ferner = "*" & Mid(temp, i + 1) & "*"
Selection.AutoFilter Field:=6, Criteria1:=suche, Operator:=xlAnd, Criteria2:=ferner
End If
Range("A2").Select
End Sub
Private Sub SpinButton1_SpinUp()
z = ActiveWindow.Zoom
z = z + 5
ActiveWindow.Zoom = z
End Sub
Private Sub SpinButton1_SpinDown()
z = ActiveWindow.Zoom
z = z - 5
ActiveWindow.Zoom = z
End Sub
***** Module 1 (Code) *****
im 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 = dname(x)
Cells(x + 2, 2).Value = dordner(x)
Cells(x + 2, 3).Value = Int(dsize(x) / 1024)
Cells(x + 2, 4).Value = DateValue(Date) - DateValue(dcreated(x))
Cells(x + 2, 5).Value = DateValue(Date) - DateValue(dlast(x))
Cells(x + 2, 6).Value = dpfad(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("B3"), Order1:=xlAscending, Key2:=Range("A3") _
, Order2:=xlAscending, Header:=xlNo
Range("A2:F2").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
Vielen Dank für Eure Hilfe!
Sven