Dim FS, Liste, WshShell

Set FS = CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
Set Liste = WScript.Arguments

' Mehrere Ordner droppen? Nie probiert, ich ziehe immer nur einen drauf
If Liste.Count > 0 Then
	For Nr = 0 To Liste.Count - 1
  		If FS.FolderExists(Liste(Nr)) Then
			Set Ordner = FS.GetFolder(Liste(Nr))
			For Each Datei In Ordner.Files
				ReNameAndMove Datei
			Next
		ElseIf FS.FileExists(Liste(Nr)) Then	'Das geht auch mit einzelnen Dateien?
			ReNameAndMove FS.GetFile(Liste(Nr))
		End If
	Next
Else
	MsgBox "Keine Dateien oder Ordner gedroppt!"
	wscript.quit
End If

MsgBox "Fertig!!!"

Private Function ReNameAndMove(Datei)
	strQuelldatei = Datei.Path
	DateiDatum = Datei.DateLastModified
	DateiOrdner = Datei.ParentFolder
	
	'Zeitinformationen extrahieren
	DateiJahr = Year(DateiDatum)
	DateiMonat = right("0" & cstr(Month(DateiDatum)),2)
	DateiTag = right("0" & cstr(Day(DateiDatum)),2)
	
	DateiStunde = right("0" & cstr(Hour(DateiDatum)),2)
	DateiMinute = right("0" & cstr(Minute(DateiDatum)),2)
	DateiSekunde = right("0" & cstr(Second(DateiDatum)),2)

	'Ziel zusammenbasteln
	strZielordner = "d:\Fotos\" & DateiJahr & "\" & DateiJahr & DateiMonat & DateiTag '& "\"
	
	strZieldatei = strZielordner & "\" & DateiJahr & "." &  DateiMonat & "." & DateiTag &  "_" & DateiStunde & "." &  DateiMinute & "." & DateiSekunde & right(strQuelldatei,4)

	' Prüfen, ob Zielordner existiert, sonst anlegen
	If Not FS.FolderExists(strZielordner) Then
		Call WshShell.Run("cmd.exe /c mkdir """& strZielordner &"""",0,true)
	End If
	
	' Prüfen, ob Datei bereits existiert, dann Zufallszahl anhängen.
	if fs.FileExists (strZieldatei) then
		strZieldatei = replace(strZieldatei, right(strQuelldatei,4), cstr(Int((99999 - 1 + 1) * Rnd + 1)) + right(strQuelldatei,4))
	end if
	
	'Datei verschieben
	Datei.Move (strZieldatei)	
End Function