' ******************************************************

' Copyright:              W.Schmelz,  28.11.2006

' ******************************************************

'Datum der Bilder eines gleich zu bestimmenden Ordners suchen, Ordner
'entsprechend dem Datum schreiben mit max. 4 wählbaren Unter-Ordnern:
'Ich habe vorgeschlagen: " Original ", " Zwischen ", " Bearbeitung ".



'Ankündigung des Programmes, Unterordner und Bildordner abfragen :
Titel="                      Bilder in Datums - Ordner verschieben"
X=VbCR&VbCR
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")

Ask=MsgBox (X&VbCR&_
 "      Einsortieren von Origial-Bildern in Datums-Ordner !"&X&VbCR&_
 "Das  Datum der Bild - Dateien  eines  Ordners wird  gesucht,"&X&_
 "Ordner  werden dem  Datum  entsprechend  angelegt,  z. B.,"&X&_
 """ 18.12.05 "",  und in diesem  Ordner  z. B.  die  Unterordner :"&X&_
 """ Original "", "" Zwischen "", "" Bearbeitung "" . Die Bild-Dateien"&X&_
 "werden zum Datum in dessen  1. Unter - Ordner verschoben               "&X&_
 VbCR&"Diese  Vorgangsweise lohnt sich nur bei sehr vielen Bildern !"&_
 X&VbCR,4+64+0,Titel)
If Ask=7 then WScript.Quit      ' Abbruch, wenn "Nein"("7")

Eingabe=InputBox (X&VbCR&_
 "Ich schlage als Unterordner der Datums-Ordner"&X&_
 "vor: ""Original"", ""Zwischen"", ""Bearbeitung"". Die"&X&_
 "Bild-Dateien werden in den ersten Unter-Ordner"&X&_
 "des Datums-Ordner verschoben, hier ""Original""!"&X&_
 "Es sind höchstens  4 Unter-Ordner möglich und"&X&_
 "diese sind mit dem  Zeichen  "" # ""  zu trennen !"&X&VbCR&_
 VbCR,Titel,"Original#Zwischen#Bearbtng")
If Eingabe="" then WScript.Quit      ' Abbruch, wenn "Cancel"("")

'Eingabe überprüfen:
Fehler="0"
If Left(Eingabe,1)="#" or Right(Eingabe,1)="#" then Fehler=1
y=1    'Leerstelle vorhanden?
Do until y>Len(Eingabe)
If Mid(Eingabe,y,1)=" " then Fehler=1
y=y+1
Loop
If Fehler=1 then MsgBox X&X&_
 "        Die Unterordner wurden falsch eingegeben                   "&_
 X&X,VbCritical,Titel:WScript.Quit

'Eingabe aufspalten in max. 4 Teile:
ReDim Preserve Name(4)
Name(1)="0"
Name(2)="0"
Name(3)="0"
Name(4)="0"

'Aufspaltung in Ort( )
Ort=Split(Eingabe,"#")

'Vorhandene Eingaben auswählen
ReDim Preserve Ort(4)
If not Ort(0)="" then Name(1)=Ort(0)
If not Ort(1)="" then Name(2)=Ort(1)
If not Ort(2)="" then Name(3)=Ort(2)
If not Ort(3)="" then Name(4)=Ort(3)

'Eingaben zur Sicherheit melden
Meld1=Name(1)
Meld2=Name(2)
Meld3=Name(3)
Meld4=Name(4)
If Meld2="0" then Meld2=""
If Meld3="0" then Meld3=""
If Meld4="0" then Meld4=""
MsgBox X&X&VbTab&_
 "Es werden folgende Unter - Ordner angelegt :                   "&_
 X&VbCR&VbTab&Meld1&X&VbTab&Meld2&X&VbTab&Meld3&X&VbTab&_
 Meld4&X&VbCR,,"                          Unterordner bilden !"



'Den gewünschten Bild - Ordner festlegen:
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder(0,StrPrompt,BrowseInfo,Root)
On Error Resume Next
Err.Clear
Pfad=ObF.Self.Path
If Err.Number<>0 then WScript.Quit



'Dateien des Ordners festlegen und anschließend das Datum
'der Bild-Dateien "File" im ausgesuchten Ordner ermitteln:
Set Data=Fso.GetFolder(Pfad).Files


'Bearbeitungsschleife starten:
'Betrachtung aller Dateien des oben ausgesuchten Ordners :

                     For each File in Data              ' < -----------

'Das Datum steht an den ersten 10 Stellen, werden 7. und 8. gestrichen,
'so wird aus " 18.12.2005 " damit " 18.12.05 "
Ordner=Left(File.DateLastModified,6)&Mid(File.DateLastModified,9,2)
Ordner=Pfad&"\"&Ordner

'Datei - Endung suchen und nur die Bilder weiter betrachten:
Ext=LCase(Right(File,3))
Endg= Ext="jpg" or Ext="bmp" or Ext="gif" or Ext="tif" or Ext="raw"
'( Endg ist "false" oder "true" )

'Nur wenn die Dateien Bilder sind, werden Ordner gemäß ihrem Datum
'angelegt, samt den gewünschten Unterordnern:
If Endg and not Fso.FolderExists(Ordner) then
Set Dat=Fso.CreateFolder(Ordner)
If not Name(1)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(1))
If not Name(2)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(2))
If not Name(3)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(3))
If not Name(4)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(4))
End If

'Es werden nur Bilder in Ordner&"\"&"Original" bzw. Name(1) geschoben:
If Endg then Fso.MoveFile File,Ordner&"\"&Name(1)&"\"

                             Next                       ' < -----------


'Schluss - Meldung:
MsgBox X&X&VbTab&_
 "Die  Bild - Dateien  des  ausgesuchten  Ordners wurden in               "&_
 X&VbTab&"die Ordner geschrieben, die dem Bild-Datum entsprechen!"&X&X,,Titel