'==========================================================================
'= 17.05.2009 - Chip Forum - Rund um Software =
'= =
'= Skript verschiebt alle Dateien aus dem Angegebenen Ordner in einen =
'= festgelegten Zielordner. Dabei werden die einzelnen Dateien nach =
'= Erstellungsdatum in entsprechende Ordner einsortiert. Falls diese =
'= nicht existieren, werden sie erstellt. =
'= =
'= Sollte eine Datei bereits vorhanden sein, wird diese nicht verschoben. =
'==========================================================================
Option Explicit
Dim fso, oShell, oSource, strSource, strTarget
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("Shell.Application")
Set oSource = oShell.BrowseForFolder(0, "Quell- Verzeichnis auswählen:", 22, 12)
strSource = oSource.Items().Item().Path
Set oSource = oShell.BrowseForFolder(0, "Ziel- Verzeichnis auswählen:", 22, 12)
strTarget = oSource.Items().Item().Path
If strSource = "" Then
MsgBox "Kein Quell- Verzeichnis ausgewählt!", 65, "Fehler"
WScript.Quit
End If
If strTarget = "" Then
MsgBox "Kein Ziel- Verzeichnis ausgewählt!", 65, "Fehler"
WScript.Quit
End If
IF MsgBox("Wollen Sie alle Dateien von " & strSource & " nach " & strTarget & " Einsortieren?", 36, "Dateien Sortieren") = vbYes Then
MoveAllFiles strSource, strTarget
End If
WScript.Echo "Einsortierung beendet"
'Ende
Function MoveAllFiles(strSource, strTarget)
Dim oFolder, oFiles, item, year, month, day
Set oFolder = fso.GetFolder(strSource)
On Error Resume Next
For Each item In oFolder.Files
year = Mid(item.DateLastModified, 7, 4)
month = year & "_" & Mid(item.DateLastModified, 4, 2)
If Not fso.FolderExist(strTarget & "\" & year) Then
fso.CreateFolder(strTarget & "\" & year)
End If
If Not fso.FolderExist(strTarget & "\" & year & "\" & month) Then
fso.CreateFolder(strTarget & "\" & year & "\" & month)
End If
fso.MoveFile item.Path, strTarget & "\" & year & "\" & month & "\" & item.Name
Next
On Error Goto 0
End Function