http://dieseyer.de • all rights reserved • © 2011 v11.4


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

' 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


http://dieseyer.de • all rights reserved • © 2011 v11.4