http://dieseyer.de • all rights reserved • © 2011 v11.4
'*** v9.3 *** www.dieseyer.de *******************************
' File: BildNummerierSortier..vbs
' Autor: W.Schmelz
' http://dieseyer.de
'
' Datei: "BildNummerierSortier."&"v"&"b"&""&""&""s"
'* *
'* " Ms"&"H"&"t"&"a.exe / XYZ."&"v"&"b"&""&""&"s" / V"&"b"&"Script " *
'* Solche oft skurrile Schreibweise soll den Virenscanner beruhigen ! *
'* - Hin und Her zwischen V-b-s und H-t-a beunruhigt meinen Scanner ! *
'* Bilder eines Ordners benennen und/oder nummerieren oder wahlweise *
'* Original-Bilder zweier Ordner durch Benennung nach Datum und Zeit *
'* zeitlich passend ineinander sortieren und dann durch nummerieren ! *
'* Dabei sind pro Kamera 6 Bilder pro Sekunde als möglich eingeplant! *
'* Das müsste für eine Weile auch für schnellere Kameras ausreichen ! *
'* ( Meine Canon - SLR schaffte schon manchmal 2 Bilder pro Sekunde ) *
'* Auf Wunsch kann vor die endgültigen Nrn. ein Name gesetzt werden. *
'* Die Kameranamen können angehängt werden:"08_Alp377_C" wie "Canon". *
'* Bei einer Zeitverschiebung beider Kameras, ist die Zeit eingebbar! *
'* Einfach mit diesen beiden Kameras gleichzeitig ein Bild schießen ! *
'* Die Bilder werden im ausgesuchten Ordner gespeichert. Reicht der *
'* Platz aber nicht, wird gefragt, wohin sonst diese Bilder sollen ! *
'* Gesteuert wird das durch Vorweg-Eingaben in eine H-t-a - Datei,die *
'* durch zwei Klapptafeln den Fall, einen Ordner zu behandeln von dem *
'* zweiten trennt,Bilder zweier Ordner zeitlich passend zu sortieren. *
'* Diese Original - Ordner bleiben, daher ist keine Sicherung nötig ! *
'* *
'************************************************************************
' Alle Objekte und das Andere für dieses Programm zur Verfügung stellen :
' ***********************************************************************
Set Fso=WScript.CreateObject ("Scripting.FileSystemObject")
Set Wss=WScript.CreateObject ("WScript.Shell")
Set Lwk=Fso.Drives
'Variable definieren, bei "Sub" - Programmen und "Function" sehr wichtig!
Dim Pfad1, Pfad2, Pfad3, Ziel, Name, xyz, Zahl, Zahl1, Zahl2, Bild(), Tag
Dim Sammel, Zeit(), Foto1, Monat, Jahr, Std, Min, Sek, Summe, Namen, Tag1
Dim Std1,Min1,Sek1, Foto, Anders, Foto2,Stelle, Folge, Numb, Wert1, Wert2
Titel=" Bilder benennen, nummerieren, sortieren !"
UV=VbCR&VbCR
Summe="0" 'Prüfen, wieviel Platz alle Bilder brauchen, s.u.
Datei1="C:\Temp\Vorfrage."&"h"&"t"&""&"a" 'Den Viren-Scanner beruhigen!
'*************************************************************************
'* *
If not Fso.FileExists (Datei1) then '*
'* ************************************* *
'* Nur beim allerersten Start dieses Folgende laufen lassen : *
'* Eine MsgBox zum Vorstellen aller Möglichkeiten dieses Programmes : *
'* *
'*************************************************************************
Msg=MsgBox ( UV&VbTab&"Bilder eines Ordner benennen "&_
"und / oder nummerieren !"&_
UV&VbTab&"( Dieser Ordner wird in einem Unterordner gesichert ! ) "&_
UV&VbTab&" . . . . . . oder . . . . . . "&_
UV&VbTab&"Das Programm sortiert auch originale Bilder"&_
" zweier Ordner "&UV&_
VbTab&"zeitlich passend ineinander, Datum und Zeit entsprechend!"&UV&_
VbTab&"Bei beiden Kameras sind bis zu 6 Bilder / Sek. eingeplant !"&UV&_
VbTab&"Bei einer Zeitverschiebung, ""frühere"" Kamera erst nennen !"&UV&_
VbTab&"Ggf. mit beiden Kameras eine Probeaufnahme anfertigen !"&UV&_
VbTab&"Alles wird im später ausgewählten Ordner gespeichert !"&UV&_
VbTab&"Wenn an der Stelle der Platz nicht reicht, wird informiert !"&_
UV&VbTab&"Die Original-Ordner bleiben, daher keine Sicherung nötig !"&_
UV, VbOkCancel, Titel)
If Msg="2" then WScript.Quit
End If
' **********************
'***********************************************************************
'* *
'* Folgende Datei ist hier vorweg eingearbeitet : *
'* ################################################ *
'* *
'* " Ms"&"H"&"t"&"a.exe / XYZ."&"v"&"b"&""&""&"s" / V"&"b"&"Script " *
'* Diese oft skurrile Schreibweise soll den Virenscanner beruhigen ! *
'* Hin und Her zwischen V-b-s und H-t-a beunruhigt meinen Scanner ! *
'* " H--t--a - Vorfrage . v--b--s " von W. Schmelz, 21.11.2008 *
'* Aus V--b--s - Datei eine H--t--a - Datei mit 3 Textfeldern und 2 *
'* Klick- Tasten zur Auswahl, samt Taste zum Abbrechen neu schaffen, *
'* aufrufen und die Einträge per Clipboard an V-b-s - Datei zurück ! *
'* Das geht natürlich auch in direkter Weitergabe mit den "Arg(i)" ! *
'* Hat aber auch den Nachteil, dass die Datei ein 2. Mal durchläuft! *
'* *
'***********************************************************************
Dim File, Text, Wort, Wort1, Wort2, Wort3, Kameras, Datei1
Set Fso=CreateObject ("Scripting.FileSystemObject")
Set Wss=CreateObject ("WScript.Shell")
If not Fso.FolderExists ("C:\Temp") then Fso.CreateFolder("C:\Temp")
Datei1="C:\Temp\Vorfrage."&"h"&"t"&"a"
If not Fso.FileExists (Datei1) then
' #####################################################
'
'**********************************************************************
'* *
'* Da bei Abholung der Eingaben aus Clipboard die V--b--s- Datei 2x ! *
'* durchlaufen wird, ist hier nur dieser erste Durchlauf ermöglicht ! *
'* Vor V--b--s - wird also H--t-a - Datei gesetzt, um gezielte Ein - *
'* gaben zu ermöglichen, die an die V--b--s - Datei zurück gehen !!! *
'* *
'**********************************************************************
Set File=Fso.CreateTextFile (Datei1, true)
Text=""&VbCR _
&"<Html>"&VbCR _
&"<Head>"&VbCR _
&"<Hta:Application"&VbCR _
&"Id=""Htaapp"""&VbCR _
&"Border=""5"""&VbCR _
&"Scroll=""No"""&VbCR _
&"SysMenu=""Yes"""&VbCR _
&"<Title>Vorgaben abfragen</Title>"&VbCR _
&"<Script Language=""VbScript"">"&VbCR _
&"Set Wss=CreateObject(""Wscript.Shell"")"&VbCR _
&"Set Fso=CreateObject(""Scripting.FileSystemObject"")"&VbCR _
&"Dat=""C:\Temp\Vorfrage.""&""h""&""t""&""a"" "&VbCR _
&"Dim Dat"&VbCR _
&"Document.ParentWindow.ClipboardData.SetData ""Text"",""#"" "&VbCR _
&""&VbCR _
&"'************************************************************"&VbCR _
&"Sub Tafel1"&VbCR _
&"Window.ResizeTo 600,690 'Neue Breite und Höhe"&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ """&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&"" \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Green""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Bei einem Ordner bitte diese Angaben machen :"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Black""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Soll ein Name vor die nummerierten """&VbCR _
&"Txt=Txt&""Bilder gesetzt werden ?<br>"""&VbCR _
&"Txt=Txt&"""""" 0 """" bedeutet keiner ! """&VbCR _
&"Txt=Txt&""Bei """" 1 """" wird jedes """&VbCR _
&"Txt=Txt&""Bild nach dem Datum<br>"""&VbCR _
&"Txt=Txt&""benannt, um ggf. nachträglich """&VbCR _
&"Txt=Txt&""Bilder einfügen zu können ! <br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Namen"""" """&VbCR _
&"Txt=Txt&""Value=""""07_Palma"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""Sollen die bisherigen Nummern erhalten bleiben - """&VbCR _
&"Txt=Txt&""oder soll<br>"""&VbCR _
&"Txt=Txt&""alles alphabetisch neu durchnummeriert """&VbCR _
&"Txt=Txt&""werden ?<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Radio"""" """&VbCR _
&"Txt=Txt&""Name=""""R2"""" ID=""""Opt1"""">"""&VbCR _
&"Txt=Txt&""Die alten Nummern sollen erhalten bleiben<br>"""&VbCR _
&"Txt=Txt&""<Input Checked Type=""""Radio"""" """&VbCR _
&"Txt=Txt&""Name=""""R2"""" ID=""""Opt2"""">"""&VbCR _
&"Txt=Txt&""Alles ist alphabetisch neu zu nummerieren<br>"""&VbCR _
&"Txt=Txt&""<br>"""&VbCR _
&"Txt=Txt&""Wenn nur ein bestimmter Teil """&VbCR _
&"Txt=Txt&""der Bilder behandelt werden<br>"""&VbCR _
&"Txt=Txt&""soll, so ist dieser zu kennzeichnen, """&VbCR _
&"Txt=Txt&""z.B. """" 533-677 """" !<br>"""&VbCR _
&"Txt=Txt&"""""" 0 """" , wenn keinerlei """&VbCR _
&"Txt=Txt&""Einschränkung sein soll !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Numb"""" """&VbCR _
&"Txt=Txt&""Value=""""0"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Input Type=""""Button"""" """&VbCR _
&"Txt=Txt&""Value=""""Mit diesen Eingaben das """&VbCR _
&"Txt=Txt&""Programm starten"""" Name=""""Information"""" """&VbCR _
&"Txt=Txt&""OnClick=Einer """&VbCR _
&"Txt=Txt&""Style=""""Background-Color:Green;Font-Size:11pt;"""&VbCR _
&"Txt=Txt&""Color:#CCCCCC;Width:270"""">"""&VbCR _
&"Txt=Txt&""</Center>"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Document.All.Info.InnerHTML=Txt"&VbCR _
&"Txt = """""&VbCR _
&"End Sub "&VbCR _
&"'***********************************"&VbCR _
&"Sub Tafel2"&VbCR _
&"Window.ResizeTo 600,690 'Neue Breite und Höhe"&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ """&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&"" \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&""<br><br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Blue""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Bei zwei Ordnern bitte folgende """&VbCR _
&"Txt=Txt&""Angaben machen :<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Black""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Welcher Name soll vor alle durchnummerierten<br>"""&VbCR _
&"Txt=Txt&""Bilder gesetzt werden ? """" 0 """" """&VbCR _
&"Txt=Txt&""bedeutet keiner !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Namen"""" """&VbCR _
&"Txt=Txt&""Value=""""08_Tuerk"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""Sollen beide Kamera - Namen angehängt werden ?<br>"""&VbCR _
&"Txt=Txt&""Z.B. """" 08_Tuerk312_P.jpg """" """&VbCR _
&"Txt=Txt&""für """"P""""- anasonic,<br>"""&VbCR _
&"Txt=Txt&""""""C"""" für Canon. Bei """" 0 """" """&VbCR _
&"Txt=Txt&""keinen Anhang !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Kameras"""" """&VbCR _
&"Txt=Txt&""Value=""""PC"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""Läuft die zweite Kamera in der Zeit voraus ?<br>"""&VbCR _
&"Txt=Txt&""Vorsprung in """"Tag:Std:Min:Sek"""" nennen !<br>"""&VbCR _
&"Txt=Txt&"""""" 0 """" bei keinem Zeitunterschied !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Anders"""" """&VbCR _
&"Txt=Txt&""Value=""""12:01:02:15"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Input Type=""""Button"""" """&VbCR _
&"Txt=Txt&""Value=""""Mit diesen Eingaben das """&VbCR _
&"Txt=Txt&""Programm starten"""" Name=""""Information"""" """&VbCR _
&"Txt=Txt&""OnClick=Zwei """&VbCR _
&"Txt=Txt&""Style=""""Background-Color:Blue;Font-Size:11pt;"""&VbCR _
&"Txt=Txt&""Color:#CCCCCC;Width:270"""">"""&VbCR _
&"Txt=Txt&""</Center>"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Document.All.Info.InnerHTML=Txt"&VbCR _
&"Txt = """""&VbCR _
&"End Sub"&VbCR _
&"'************************************************************"&VbCR _
&"Sub Einer"&VbCR _
&"Ask=MsgBox (VbCR&VbCR&_"&VbCR _
&"""Wurden zu dem Ordner die richtigen Angaben gemacht ?""&_"&VbCR _
&""" ""&VbCR&VbCR&_"&VbCR _
&""" Wenn sicher , dann """" ""&_"&VbCR _
&"""Ja """" anklicken !""&_"&VbCR _
&"VbCR&VbCR,VbCritical+VbYesNo, _"&VbCR _
&""" Angaben zu einem Ordner"")"&VbCR _
&"If Ask=""7"" then Exit Sub"&VbCR _
&"Wort1=Namen.Value"&VbCR _
&"If Wort1="""" then Wort1=""0"""&VbCR _
&"If Document.All.Opt1.Checked then Wort2=""1"""&VbCR _
&"If Document.All.Opt2.Checked then Wort2=""2"""&VbCR _
&"Wort3=Numb.Value"&VbCR _
&"If Wort3="""" then Wort3=""0"""&VbCR _
&"If (Left(Wort1,1)="" "" or Left(Wort2,1)="" "" or _"&VbCR _
&"Left(Wort3,1)="" "") _"&VbCR _
&" then Fso.DeleteFile Dat "&VbCR _
&"If not Fso.FileExists (Dat) then Self.Close"&VbCR _
&"Wort=""1#""&Wort1&""#""&Wort2&""#""&Wort3"&VbCR _
&"Document.ParentWindow.ClipboardData.SetData ""Text"",Wort"&VbCR _
&"Self.Close"&VbCR _
&"End Sub"&VbCR _
&"'************************************************************"&VbCR _
&"Sub Zwei"&VbCR _
&"Ask=MsgBox (VbCR&VbCR&_"&VbCR _
&"""Wurden zu beiden Ordnern richtige Angaben gemacht ?""&_"&VbCR _
&""" ""&VbCR&VbCR&_"&VbCR _
&""" Wenn sicher , dann """" ""&_"&VbCR _
&"""Ja """" anklicken !""&_"&VbCR _
&"VbCR&VbCR,VbCritical+VbYesNo,_"&VbCR _
&""" Angaben zu den 2 Ordnern"")"&VbCR _
&"If Ask=""7"" then Exit Sub"&VbCR _
&"Wort1=Namen.Value"&VbCR _
&"If Wort1="""" then Wort1=""0"""&VbCR _
&"Wort2=Kameras.Value"&VbCR _
&"If Wort2="""" then Wort2=""0"""&VbCR _
&"Wort3=Anders.Value"&VbCR _
&"If Wort3="""" then Wort3=""0"""&VbCR _
&"If (Left(Wort1,1)="" "" or Left(Wort2,1)="" "" _"&VbCR _
&"or Left(Wort3,1)="" "") _"&VbCR _
&" then Fso.DeleteFile Dat "&VbCR _
&"If not Fso.FileExists (Dat) then Self.Close"&VbCR _
&"Wort=""2#""&Wort1&""#""&Wort2&""#""&Wort3"&VbCR _
&"Document.ParentWindow.ClipboardData.SetData ""Text"",Wort"&VbCR _
&"Self.Close"&VbCR _
&"End Sub"&VbCR _
&"'************************************************************"&VbCR _
&"Window.ResizeTo 600,250"&VbCR _
&"Window.MoveTo 200,50"&VbCR _
&"</Script>"&VbCR _
&"</Head>"&VbCR _
&"<Body BgColor=""#d3d3d3"" Style=""Font-Family:Arial; "&VbCR _
&"Font-Size:14pt;Color:Black"">"&VbCR _
&"<br><br>"&VbCR _
&"<Center>"&VbCR _
&"<Input Type=""Button"" Name=""Ende"" "&VbCR _
&"Value=""Programm abbrechen"" _"&VbCR _
&"OnClick=""Self.Close"" Style=""Font-Family: "&VbCR _
&"Arial;Font-Size:14pt;Color:Red"">"&VbCR _
&"<br><br>"&VbCR _
&"<Input Type=""Button"" Name=""Ende"" "&VbCR _
&"Value=""Bilder eines Ordners nummerieren"""&VbCR _
&" OnClick=""Tafel1"" Style=""Font-Family:Arial; "&VbCR _
&"Font-Size:13pt;Color:Green;Width:270"">"&VbCR _
&" <Input Type=""Button"" Name=""Start"" """""&VbCR _
&"Value=""Bilder zweier Ordner einsortieren"""&VbCR _
&" OnClick=""Tafel2"" Style=""Font-Family:Arial; "&VbCR _
&"Font-Size:13pt;Color:Blue;Width:270"">"&VbCR _
&"<br><br>"&VbCR _
&"</Center>"&VbCR _
&"<Center><div Id=Einblenden></Center>"&VbCR _
&"<Center><div Id=Info></Center>"&VbCR _
&"</Body>"&VbCR _
&"</Html>"&VbCR _
&""&VbCR _
File.WriteLine(Text)
File.Close
' Die hier geschriebene H--t--a - Datei wird vornweg ans Laufen gebracht :
' *************************************************************************
Wss.Run Datei1, , true '"true" heißt: erst weiter, wenn beendet
End If
' ############################
' Bei Abbruch in Datei 1 ist an dieser Stelle abzubrechen :
' *********************************************************
If not Fso.FileExists (Datei1) then WScript.Quit
' " Wort ", d.h. die Ergebnisse der Voranfage, aus dem Clipboard abholen :
' ************************************************************************
Set Arg=WScript.Arguments
If Arg.Count=0 then
Board 'Subprogramm zur Abfrage des Zwischenspeichers
WScript.Quit
End If
Wort=Arg(0)
' *********************************************************************
Sub Board
Wss.Run "Ms"&"H"&"t"&"a.exe V"&"b"&"Script:"&_
"(CreateObject(""WScript.Shell"")."&_
"Run("""""""& WScript.ScriptFullName&""""" """""""&Chr(38)&_
"Document.ParentWindow.ClipboardData."&_
"GetData(""Text"")"&Chr(38)&"""""""""))(Window.Close)"
End Sub
' *********************************************************************
WScript.Sleep 500
If Fso.FileExists (Datei1) then Fso.DeleteFile Datei1
' Den Speicher zur Sicherheit gezielt mit neutralem Text überschreiben!
' *********************************************************************
Wss.Run "Ms"&"H"&"t"&"a.exe V"&"b"&"Script:"&_
"(Document.ParentWindow.ClipboardData."&_
"SetData(""Text"","""&" Ätsch ! ?"&"""))(Window.Close)"
If Wort="#" then WScript.Quit 'Wenn Fenster mit "X" geschlossen!
'Die Voreintragungen, das Wort1 bzw. Wort2 festlegen :
'*****************************************************
Wort1=""
Wort2=""
If Left(Wort,1)="1" then Wort1=Right(Wort,Len(Wort)-2)
If Left(Wort,1)="2" then Wort2=Right(Wort,Len(Wort)-2)
If Wort1<>"" then 'Ende s. Dateimitte
' §§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§
'Folgende ältere Datei ist in diesem Programm eingearbeitet :
' ***********************************************************
' * *
' * Dateiname : " BildName.v-b-s " *
' * *
' * Bildnamen im Ordner ändern, alte Nr. bleibt erhalten, *
' * - ggf. nur einen ausgewählten Bereich neu benennen! *
' * Oder alles (!) wird neu sortiert mit laufender Nr. ! *
' * Oder Originale werden nach Entstehungsdatum benannt- *
' * es sind bis zu 6 Bilder mit gleichem Datum möglich -, *
' * um sie in andere Gruppen zeitlich passend einzufügen! *
' * *
' * CopyRight: W. Schmelz 27.10.2008 *
' * *
' ***********************************************************
Set Fso = CreateObject ("Scripting.FileSystemObject")
'Dim UV, UVW, XX, NN, Pfad, Fso, Ttl, Zahl, Bild(), Weg
'Dim Zone, Anfg, Ende, Nrn()
' Neu bstimmen, damit keine Doppelfestlegungen :
' **********************************************
Dim UVW, XX, NN, Pfad, Titel, Weg, Zone, Anfg, Ende, Nrn()
' Ebenso sind viele Bezeichnungen dieser alten Datei zu ändern !
'***************************************************************
'Abkürzungen für die MsgBox
UV=VbCR&VbCR
UVW=UV&VbCR
XX=VbTab
Titel=" Bilddateien eines Ordners umbenennen !"
' Neu in dieser eingearbeiteten Datei sind :
'*******************************************
' Die Anfangs - Eingaben in alle deren Bestandteile unterteilen :
' ****************************************************************
Zahl=Split(Wort1,"#")
' Die Anfangs - Eingaben definieren u. genauestens kontrollieren :
' ****************************************************************
Namen=Zahl(0)
Folge=Zahl(1)
Numb=Zahl(2)
' Eine Kontrollmeldung aller der vorhin getätigten Vor-Auswahlen :
' ****************************************************************
Satz=Satz&UV&VbCR&"Folgende Angaben wurden bisher eingetragen"
Satz=Satz&VbCR&"*************************************"
If Namen="0" then _
Satz=Satz&UV&"Es wird kein Name vor diese Bilder gesetzt !"
If Namen="1" then _
Satz=Satz&UV&"Die Bilder werden nach dem Datum benannt !"&UV&VbCR
If Len(Namen)>=2 then
Satz=Satz&UV&"Vor alle Bilder kommt der gemeinsame Name :"
Satz=Satz&VbCR&Namen
End If
If Namen<>"1" then
Satz=Satz&UV&"Bei der Nummerierung der Bilder des Ordners"&VbCR
If Folge="1" then
Satz=Satz&"soll die bisherige Nummer des Bildes bleiben !"
else
Satz=Satz&"werden die Bilder alphabetisch nummeriert !"
End If
If Numb="0" then
Satz=Satz&UV&"Es werden alle Bilder des Ordners behandelt !"
Satz=Satz&UV&UV
else
Satz=Satz&UV&"Nur die Bilder "&Numb&" werden behandelt !"
Satz=Satz&UV&UV
End If
End If
Test=MsgBox ( Satz, VbInformation + VbOkCancel, Titel )
If Test="2" then WScript.Quit
' Den Bild - Ordner in einem Browser auswählen :
' **********************************************
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
Set All=Nothing
On Error GoTo 0 'Ignorieren der Fehler wieder aufheben !
Msg=MsgBox ( UV&VbCR&"Zur Behandlung wurde ausgewählt : "&Pfad&_
UV&VbCR, VbInformation + VbOkCancel, Titel )
If Msg="2" then WScript.Quit
' Jetzt folgt die Kette der benötigten Sub - Programm - Aufrufe :
' ***************************************************************
Wahlen
If Weg<>"1" then Sicher 'Alle Bilder sichern!
Sammeln 'Ist noch unsortiert!
If not Zone="" then Bereich
If Weg=1 then Pruef1 'Sichern erst danach !
Sortieren 'Die Bilder sortieren!
If Weg=2 then Pruef2
NeuName
' ************************************************************
' Es folgen jetzt alle die oben aufgerufenen Sub - Programme :
' ************************************************************
Sub Wahlen
' Der nun folgende Abschnitt wurde weitgehend umgearbeitet !
' **********************************************************
' Die Zahl der Bilder im Ordner prüfen :
' **************************************
Set FsF=Fso.GetFolder(Pfad)
Set FsFf=FsF.Files
Zahl="0"
For each File in FsFf
Zahl=1+Zahl
Next
If Zahl="0" then MsgBox UVW&_
" Dies Verzeichnis enthält keine Dateien !"&_
UVW, VbCritical, Titel : WScript.Quit
' Die Eingaben vom Anfang in dieses bestehende Programm einarbeiten :
' *******************************************************************
NN=Namen
If NN="" then WScript.Quit
If NN="0" then NN=""
If NN="1" then
Sicher 'Die Bilder sichern
Datum 'Umbenennung gemäß Datum durchführen!
End If
Weg=Folge 'Bezeichnungen umarbeiten !
If Weg="" then WScript.Quit
If NN="" then
If Weg="2" then Frg2=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
"Die Bilder werden nicht benannt, aber alphabet. nummeriert ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg2="7" then WScript.Quit
End If
If NN<>"" then
If Weg="2" then Frg2=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
"Bilder werden """&NN&""" genannt, alphabet. nummeriert ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg2="7" then WScript.Quit
End If
If Numb="0" then Numb=""
If Weg="1" then Zone=Numb
If Weg="1" and Zone<>"" then Teil="Einzelne "
If NN="" then
If Weg="1" then Frg4=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
Teil&"Die Bilder werden nicht benannt, aber die Nr. bleibt ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg4="7" then WScript.Quit
End If
If NN<>"" then
If Weg="1" then Frg4=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
Teil&"Bilder werden """&NN&""" genannt, die Nr. bleibt ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg4="7" then WScript.Quit
End If
If Weg="1" then 'Falls alte Nrn. bleiben sollen:
' Sind die vorhandenen Nummern mindestens 3 - stellig ?
' Gibt es Probleme in der Bezeichnung (08_0030_C.jpg) ?
' *****************************************************
Set Ort=Fso.GetFolder(Pfad).Files
For each File in Ort
Nr=Left(Right(File,7),3)
Z1=Left(Nr,1)
Z2=Mid(Nr,2,1)
Z3=Right(Nr,1)
If not (Asc(Z1)>47 and Asc(Z1)<58 and Asc(Z2)>47 and _
Asc(Z2)<58 and Asc(Z3)>47 and Asc(Z3)<58) then _
MsgBox UVW&" Fehler in der alten Nummerierung !"&_
UV&" Die Nr. sind nicht mind. 3 - stellig !"&_
UVW, VbCritical, Titel : WScript.Quit
Next
End If
End Sub
' ******************************************************************
Sub Sicher
' Alle Dateien im Ordner "Pfad" zählen, ihre Gesamtgröße ermitteln :
' ******************************************************************
Set Data=Fso.GetFolder(Pfad).Files
Zahl="0"
For each i in Data
Zahl=1+Zahl
Summe=Summe+i.Size 'Summierung der Dateigrößen
Next
' Festplatte "X:\" analysieren, ob noch genug Platz, sonst Abbruch :
' ******************************************************************
Ziel=Left(Pfad,2) 'Die Ziel-Festplatte ermitteln
Set Lwrk=Fso.GetDrive(Ziel)
If Lwrk.FreeSpace<Summe+300000000 then '300 MB Rest lassen!
MsgBox UV&UV&"Das Speichermedium "&Ziel&"\ hat nicht genug"&_
UV&"Restanteil an Platz ! ! !"&UV&UV,VbCritical,Titel:WScript.Quit
End If
' Wenn dieser noch nicht vorhanden, einen Sicherungsordner anlegen :
' ******************************************************************
If not Fso.FolderExists (Pfad&"\Sicherng") then
Fso.CreateFolder(Pfad&"\Sicherng")
else
MsgBox UV&UV&" Es existiert bereits ein Sicherungsordner !?"&_
UV&UV, VbCritical, Titel : WScript.Quit
End If
' Alle Bilder des ausgesuchten Ordners werden jetzt gesichert :
' *************************************************************
Set Sich=Fso.GetFolder(Pfad)
Set Sichg=Sich.Files
For each File in Sichg
Fso.CopyFile File,Pfad&"\Sicherng\"
Next
' ********************************************************
' Die Kontrolle, ob die Sicherung korrekt angelegt wurde !
' Sonst der Abbruch, wenn die Ordner-Größen ungleich sind!
' ********************************************************
Set Folder1 = Fso. GetFolder ( Pfad ) 'Gesamtordner!
Set Folder2 = Fso. GetFolder ( Pfad & "\Sicherng\" )
Wert1 = Folder1.Size/2 ' " /2 " : Die Sicherung ist dabei!
Wert2 = Folder2.Size
If Wert1 <> Wert2 then
MsgBox UV & UV & _
"Die Sicherung ist nicht gelungen !" & UV & _
"So muss halt abgebrochen werden !" & UV & _
"Ggf. alles noch einmal versuchen !" & UV & _
UV, VbInformation, Titel
Fso.DeleteFolder ( Pfad & "\Sicherng" )
WScript.Quit
End If
End Sub
' ******************************************************************
Sub Datum
' Prüfen, ob nur Bild - Dateien enthalten, sonst kommt der Abbruch :
' ******************************************************************
Set Data=Fso.GetFolder(Pfad).Files
For each i in Data
Endg=LCase(Fso.GetExtensionName(i)) 'Datei-Endung von i
If not (Endg="jpg" or Endg="tif" or Endg="raw") then
MsgBox UV&i&" ist keine Bild-Datei !!!"&UV, , Titel
WScript.Quit
End If
Next
' Auf die Sek. exaktes Datum der Original - Dateien "i" des Ordners :
' *******************************************************************
Set Data=Fso.GetFolder(Pfad).Files
For each i in Data
Name=Left(i.DateLastModified,19) 'Datum der originalen Bilder i
'In "Name" Tag, Monat, Jahr, Std, Min, Sek finden:
Tag=Left(Name,2)
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2)
'*****************************************************************
'* *
'* Bilder des Ordners benennen mit dem Namen gemäß der Zeit: *
'* Falls gleicher Zeit- Name schon da, an den neuen gleichen *
'* Namen "1" bis "5" anhängen, wird dann dahinter sortiert ! *
'* Es sind also 6 Bilder pro Sekunde dabei hier eingeplant ! *
'* *
'*****************************************************************
Endg=LCase(Fso.GetExtensionName(i)) 'Datei-Endung von i
Name=Pfad&"\"&Jahr&Monat&Tag&Std&Min&Sek 'ohne Datei- Endung
If not Fso.FileExists(Name&"."&Endg) then
Fso.MoveFile i,Name&"."&Endg
ElseIf (Fso.FileExists(Name&"."&Endg) and not _
Fso.FileExists(Name&"_1."&Endg)) then
Name=Name&"_1."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and not _
Fso.FileExists(Name&"_2."&Endg)) then
Name=Name&"_2."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and _
Fso.FileExists(Name&"_2."&Endg) and not _
Fso.FileExists(Name&"_3."&Endg)) then
Name=Name&"_3."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and _
Fso.FileExists(Name&"_2."&Endg) and _
Fso.FileExists(Name&"_3."&Endg) and not _
Fso.FileExists(Name&"_4."&Endg)) then
Name=Name&"_4."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and _
Fso.FileExists(Name&"_2."&Endg) and _
Fso.FileExists(Name&"_3."&Endg) and _
Fso.FileExists(Name&"_4."&Endg) and not _
Fso.FileExists(Name&"_5."&Endg)) then
Name=Name&"_5."&Endg
Fso.MoveFile i,Name
End If
Next
' Eine Schlussmeldung wird jetzt ausgegeben :
' *******************************************
MsgBox UV&XX&"Die Bilder sind nach dem Datum benannt !"&_
" "&UV, , Titel
WScript.Quit
End Sub
' *************************************************************
Sub Sammeln
' Die Bilder sammeln, nummeriert nach derem Eingang !
' ***************************************************
Set Ort=Fso.GetFolder(Pfad).Files
i=1
For each File in Ort
ReDim Preserve Bild(i)
Ext=LCase(Right(File,3))
If Weg=1 then
Nr=Left(Right(File,8),4)
Z1=Left(Nr,1)
Z2=Mid(Nr,2,1)
Z3=Mid(Nr,3,1)
Z4=Right(Nr,1)
' Prüfen, ob mindestens vierstellige Nr. da sind :
' ************************************************
If not (Asc(Z1)>47 and Asc(Z1)<58 and Asc(Z2)>47 and _
Asc(Z2)<58 and Asc(Z3)>47 and Asc(Z3)<58 and Asc(Z4)>47 _
and Asc(Z4)<58) then Drei
'(Sub-Programm, das prüft, ob wenigstens dreistellige Nr.,
' und evtl. eine "0" ergänzt !)
End If
Endg= Ext="jpg" or Ext="bmp" or Ext="gif" or Ext="tif" or Ext="raw"
If Endg then Bild(i)=File
If not Endg then i=i-1
i=i+1
Next
Zahl=i-1
' Sind keine Bilder vorhanden ? !
' *******************************
If Zahl="0" then
MsgBox UV&UV&XX&_
"**********************************"&UV&_
XX&"Es ist kein Bild vorhanden !!! "&_
" "&UV&_
XX&"**********************************"&_
UVW, VbCritical, Titel : WScript.Quit
End If
If Zone="" then
Anfg="1"
Ende=Zahl
End If
End Sub
' *************************************************************
Sub Bereich
Lang=Len(Zone)
If Mid(Zone,2,1)="-" then
Anfg=Left(Zone,1)
Ende=Mid(Zone,3,Lang-2)
End If
If Mid(Zone,3,1)="-" then
Anfg=Left(Zone,2)
Ende=Mid(Zone,4,Lang-3)
End If
If Mid(Zone,4,1)="-" then
Anfg=Left(Zone,3)
Ende=Mid(Zone,5,Lang-4)
End If
End Sub
' *************************************************************
Sub Pruef1
' Ist eine Nr. etwa doppelt vorhanden ?
' *************************************
x=1
Do until x>Zahl
y=1
Do until y>Zahl
If Mid(Bild(y),Len(Bild(y))-7,4)=Mid(Bild(x),Len(Bild(x))-7,4) _
and x<>y then MsgBox UVW&_
" In Nummerierung war Nr. doppelt !"&_
UVW, VbCritical, Titel : WScript.Quit
y=y+1
Loop
x=x+1
Loop
Sicher
End Sub
' *************************************************************
Sub Sortieren
' Diese Bilder alphabetisch sortieren :
' *************************************
For i=1 to Zahl
For k=i+1 to Zahl
If Bild(i)>Bild(k) then
Y=Bild(i)
Bild(i)=Bild(k)
Bild(k)=Y
End if
Next
Next
End Sub
' *************************************************************
Sub Pruef2
' Ist der Name schon vorhanden ?
' ******************************
Lang=Len(NN)
Da="0"
x=1
Do until x>Zahl
If Left(Fso.GetFileName(Bild(x)),Lang)=NN then Da=1
x=x+1
Loop
If Da=0 then Exit Sub
' Sonst einen Hilfsnamen festlegen :
' **********************************
x=1
Do until x>Zahl
Ext=Lcase(Right(Bild(x),3))
Fso.MoveFile Bild(x),Pfad&"\"&"abc"&x&"."&Ext
Bild(x)=Pfad&"\"&"abc"&x&"."&Ext
x=x+1
Loop
End Sub
' *************************************************************
Sub Drei
' Die Bilder sammeln, nummeriert nach ihrem Eingang, und prüfen :
' ***************************************************************
Set Ort=Fso.GetFolder(Pfad).Files
i=1
For each File in Ort
ReDim Preserve Bild(i)
Ext=LCase(Right(File,3))
' Den Ordnerinhalt auf Bilder prüfen :
' ************************************
Endg= Ext="jpg" or Ext="bmp" or Ext="gif" or Ext="tif" or Ext="raw"
If Endg then Bild(i)=File
If not Endg then i=i-1
i=i+1
Next
Zahl=i-1
' Sind keine Bilder vorhanden ? !
' *******************************
If Zahl="0" then
MsgBox UV&UV&XX&_
"**********************************"&UV&_
XX&"Es ist kein Bild vorhanden !!! "&_
" "&UV&_
XX&"**********************************"&_
UVW, VbCritical, Titel : WScript.Quit
End If
' Nrn. der Bilder 4 - stellig machen, Bild(i) neu definieren :
' ************************************************************
i=1
Do until i>Zahl
Z4=Left(Right(Bild(i),8),1)
If not (Asc(Z4)>47 and Asc(Z4)<58) then
Fso.MoveFile Bild(i), _
Left(Bild(i),Len(Bild(i))-7)&"0"&Right(Bild(i),7)
Bild(i)=Left(Bild(i),Len(Bild(i))-7)&"0"&Right(Bild(i),7)
End If
i=i+1
Loop
Sortieren 'Bilder mit 4 - stelligen Nrn. neu sortieren
' Neue Nrn(i) der Bilder ermitteln :
' **********************************
i=1
Do until i>Zahl
ReDim Preserve Nrn(i)
Nrn(i)=Left(Right(Bild(i),8),4)
i=i+1
Loop
' Den evtl. gewählten Bereich jetzt überprüfen :
' **********************************************
Ja="2"
If not Zone="" then
Bereich
Ja="0"
i=1
Do until i>Zahl
If CInt(Nrn(i))=CInt(Anfg) then
Ja=1+Ja
Anfg=i
End If
If CInt(Nrn(i))=CInt(Ende) then
Ja=1+Ja
Ende=i
End If
i=i+1
Loop
End If
If Ja<>2 then _
MsgBox UVW&" Der gewählte Bereich war ungeeignet !"&_
UVW, VbCritical, Titel : WScript.Quit
' Festlegungen, falls kein begrenzter Bereich gewählt wurde :
' ***********************************************************
If Zone="" then
Anfg="1"
Ende=Zahl
End If
' Die Bilder werden jetzt neu benannt :
' *************************************
i=1
Do until i>Zahl
Ext=LCase(Right(Bild(i),3))
If (i>CInt(Anfg)-1 and i<1+CInt(Ende)) then _
Fso.MoveFile Bild(i),Pfad&"\"&NN&Nrn(i)&"."&Ext
i=i+1
Loop
' Die Schlussmeldung wird jetzt ausgegeben :
' ******************************************
MsgBox UVW&XX&" Die Dateien wurden umbenannt !"&UVW, , Titel
WScript.Quit 'Abschalten, damit kein Übergang auf 2 Ordner
End Sub
' *************************************************************
Sub NeuName
' Den evtl. gewählten Bereich abstecken und dann überprüfen :
' ***********************************************************
Ja="2"
If not Zone="" then
Ja="0"
i=1
Do until i>Zahl
If CInt(Left(Right(Bild(i),8),4))=CInt(Anfg) then
Ja=1+Ja
Anfg=i
End If
If CInt(Left(Right(Bild(i),8),4))=CInt(Ende) then
Ja=1+Ja
Ende=i
End If
i=i+1
Loop
End If
If Ja<>2 then
MsgBox UVW&" Der gewählte Bereich war ungeeignet !"&_
UVW, VbCritical, Titel : WScript.Quit
End If
i=1
Do until i>Zahl
Ext=LCase(Right(Bild(i),3))
If Weg=1 then Nr=Left(Right(Bild(i),8),4)
If Weg=2 then
If i<10 then Nr="000"&i
If 9<i and i<100 then Nr="00"&i
If 99<i and i<1000 then Nr="0"&i
End If
If (i>CInt(Anfg)-1 and i<1+CInt(Ende)) then
Fso.MoveFile Bild(i),Pfad&"\"&NN&Nr&"."&Ext
End If
i=i+1
Loop
' Eine Schlussmeldung wird jetzt ausgegeben :
' *******************************************
MsgBox UVW&XX&" Die Dateien wurden umbenannt !"&UVW, , Titel
WScript.Quit 'Abschalten,damit kein Übergang auf 2. Ordner
End Sub
End If ' Ende vom 1. Programm
' §§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§
' Das 2. Programm, das die Bilder zweier Ordner zeitlich sortiert !
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
' Die Anfangs - Eingaben in alle einzelne Bestandteile unterteilen:
' *****************************************************************
Zahl=Split(Wort2,"#")
' Die Anfangs - Eingaben definieren und genauestens kontrollieren :
' *****************************************************************
Namen=Zahl(0)
Kameras=Zahl(1)
Anders=Zahl(2)
If Len(Kameras)>2 then MsgBox UV&_
"Die Kamera-Namen wurden falsch eingegeben !"&UV, _
VbCritical, Titel : WScript.Quit
' Die Kontrolle der eingebenen Zeitverschiebung, diese ist wichtig!
' *****************************************************************
If not Anders="0" then
Warnung=UV&UV&"Die Zeitverschiebung wurde falsch angegeben !"&UV&UV
Testen=""
For i=1 to Len(Anders) ' " : " in den Zeiten herausnehmen!
If Mid(Anders,i,1)=":" then
Testen=Testen&""
else
Testen=Testen&Mid(Anders,i,1)
End If
Next
' In der Zeit nur Zahlen enthalten und auch sonst alles sinnvoll ?
' ****************************************************************
For i=1 to Len(Testen)
If not (Asc(Mid(Testen,i,1))>=48 and Asc(Mid(Testen,i,1))<=57) _
then MsgBox Warnung, VbCritical, Titel : WScript.Quit
Next
If Left(Right(Anders,3),1)<>":" then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Right(Anders,2)>59 then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If (Len(Anders)>=6 and Left(Right(Anders,6),1)<>":") then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Len(Anders)>=5 then _
If Left(Right(Anders,5),2)>59 then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If (Len(Anders)>=9 and Left(Right(Anders,9),1)<>":") then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Len(Anders)>=8 then _
If Left(Right(Anders,8),2)>23 then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Left(Anders,1)=":" then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Len(Anders)=11 and Left(Anders,2)>28 then _
MsgBox UV&UV&"Die Anzahl der Tage "&_
"ist zu groß gewählt worden !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
' Eine Kontrollmeldung aller der vorhin getätigten Vor-Auswahlen :
' ****************************************************************
Satz=Satz&UV&VbCR&"Folgende Angaben wurden bisher eingetragen"
Satz=Satz&VbCR&"*************************************"
Satz=Satz&UV&"Vor alle Bilder kommt der gemeinsame Name :"&VbCR
If Namen="0" then
Satz=Satz&"Es wird kein Name davor gesetzt !"
else
Satz=Satz&Namen
End If
Satz=Satz&UV&"Angehängte Kamera - Namen sollen werden:"&VbCR
If Kameras="0" then
Satz=Satz&"Der Kamera-Name wird nicht angehängt !"
else
Satz=Satz&""" "&Left(Kameras,1)&" "" für die 1., "" "
Satz=Satz&Right(Kameras,1)&" "" bei der 2. Kamera "
End If
Satz=Satz&UV&"Der Zeitvorsprung der 2. Kamera, der beim"&VbCR
Satz=Satz&"Sortieren berücksichtigt werden soll, beträgt:"&VbCR
Satz=Satz&Anders&" ( Tag : Std : Min : Sek )"&UV&UV
Test=MsgBox( Satz, VbInformation + VbOkCancel, Titel )
If Test="2" then WScript.Quit
' *******************************************************************
' Die MsgBox zum Vorstellen der weiteren Anfragen dieses Programmes :
' *******************************************************************
Msg=MsgBox (UV&VbCR&VbTab&"Bitte gleich zwei Ordner"&_
" mit den originalen Bildern "&UV&VbTab&_
"aussuchen, deren Bilder zeitlich passend ineinander"&UV&_
VbTab&"sortiert werden dem Aufnahmedatum entsprechend!"&UV&_
VbTab&"Bei Zeitverschiebung, ""frühere"" Kamera erst nennen!"&UV&_
VbTab&"Alles wird im später gewählten Ordner gespeichert !"&_
UV&VbTab&"Wenn dort der Platz nicht reicht, wird nachgefragt !"&_
UV&UV, VbOkCancel, Titel)
If Msg="2" then
If Fso.FileExists(Datei1) then Fso.DeleteFile Datei1
WScript.Quit
End If
' ****************************************************************
' * Den 1. Bild - Ordner jetzt in folgendem Browser aussuchen : *
' ****************************************************************
Wss.Popup UV&UV&VbTab&_
"Bitte den 1. Bildordner aussuchen !"&_
" "&_
UV&UV, 3, Titel, VbInformation
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder ( 0, StrPrompt, BrowseInfo, Root)
On Error Resume Next
Err.Clear
Pfad1=ObF.Self.Path
If Err.Number<>0 then WScript.Quit
Set All=Nothing
' Alle Dateien in dem Ordner 1 zählen und danach durchprüfen :
' ************************************************************
Set Data=Fso.GetFolder(Pfad1).Files
Zahl1="0"
Endg="0"
For each i in Data
Zahl1=1+Zahl1
Summe=Summe+i.Size 'Summierung der Dateigrößen
Ende=LCase(Right(i,3))
If not (Ende="jpg" or Ende="raw") then Endg="1"
Next
If Zahl1="0" then
MsgBox UV&UV&"Der Ordner "&Pfad1&" ist leer !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
If Endg="1" then
MsgBox UV&UV&"Der Ordner "&Pfad1&_
" enthält nicht nur Bilder !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
'******************************************************************
'* Prüfen, ob im Ordner 1 mehr als 6 Bilder / Sek. vorliegen : *
'* Für diese Bilder die Zeit(k) = Tag&Std&Min&Sek feststellen ! *
'******************************************************************
Set Data=Fso.GetFolder(Pfad1).Files
ReDim Preserve Zeit(Zahl1)
k=1 'Für die Zeit(k)
For each i in Data
Name=Left(i.DateLastModified,19)
Tag=Left(Name,2) 'Tag der Aufnahme ermitteln!
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2) 'Std der Aufnahme ermitteln!
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2) 'Sek der Aufnahme ermitteln!
Zeit(k)=Jahr&Monat&Tag&Std&Min&Sek
k=k+1
Next
' Alle diese "Zeit(k)" ihrem Datum gemäß untereinander sortieren :
' *****************************************************************
For i=1 to Zahl1
For k=i+1 to Zahl1
If Zeit(i)>Zeit(k) then
xyz=Zeit(i)
Zeit(i)=Zeit(k)
Zeit(k)=xyz
End if
Next
Next
' Kontrolle, wie oft die gleiche Zeit(k) und ggf. eine Warnmeldung :
' ******************************************************************
Sammel="1"
For i=1 to Zahl1
If i>1 then
If Zeit(i)=Zeit(i-1) then Sammel=Sammel+1
If Zeit(i)<>Zeit(i-1) then Sammel="1" 'Neuanfang
If Sammel>6 then
MsgBox UV&UV&_
"Im Ordner "" "&Pfad1&" "" sind mehr als 6 Bilder / Sek. !"&_
UV&"Eines dieser Kette ist Bild "&i&" !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
End If
Next
'****************************************************************
'* Den 2. Bild - Ordner jetzt in folgendem Browser aussuchen : *
'****************************************************************
Wss.Popup UV&UV&VbTab&_
"Bitte den 2. Bildordner aussuchen !"&_
" "&_
UV&UV, 3, Titel, VbInformation
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder( 0, StrPrompt, BrowseInfo, Root )
On Error Resume Next
Err.Clear
Pfad2=ObF.Self.Path
If Err.Number<>0 then WScript.Quit
Set All=Nothing
' Alle Dateien in dem Ordner 2 zählen und danach überprüfen :
' ***********************************************************
Set Data=Fso.GetFolder(Pfad2).Files
Zahl2="0"
Endg="0"
For each i in Data
Zahl2=1+Zahl2
Summe=Summe+i.Size 'Summierung der Dateigrößen
Ende=LCase(Right(i,3))
If not (Ende="jpg" or Ende="raw") then Endg="1"
Next
If Zahl2="0" then
MsgBox UV&UV&"Der Ordner "&Pfad2&" ist leer !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
If Endg="1" then
MsgBox UV&UV&"Der Ordner "&_
Pfad2&" enthält nicht nur Bilder !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
' Sind diese beiden Ordner 1 und 2 tatsächlich verschieden ?
' **********************************************************
If Pfad1=Pfad2 then
MsgBox UV&UV&_
"Es wurden nicht zwei verschiedene Ordner ausgewählt !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
'******************************************************************
'* Prüfen, ob im Ordner 2 mehr als 6 Bilder / Sek. vorliegen : *
'* Für diese Bilder die Zeit(k) = Tag&Std&Min&Sek feststellen ! *
'******************************************************************
Set Data=Fso.GetFolder(Pfad2).Files
ReDim Preserve Zeit(Zahl2)
k=1 'Für die Zeit(k)
For each i in Data
' ************************************
Name=Left(i.DateLastModified,19)
Tag=Left(Name,2) 'Tag der Aufnahme ermitteln!
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2) 'Sek der Aufnahme ermitteln!
Zeit(k)=Jahr&Monat&Tag&Std&Min&Sek
k=k+1
Next
' Alle diese "Zeit(k)" ihrem Datum gemäß untereinander sortieren :
' *****************************************************************
For i=1 to Zahl2
For k=i+1 to Zahl2
If Zeit(i)>Zeit(k) then
xyz=Zeit(i)
Zeit(i)=Zeit(k)
Zeit(k)=xyz
End if
Next
Next
' Eine Kontrolle, wie oft gleiche "Zeit(k)" und ggf. Warnmeldung :
' *****************************************************************
Sammel="1"
For i=1 to Zahl2
If i>1 then
If Zeit(i)=Zeit(i-1) then Sammel=Sammel+1
If Zeit(i)<>Zeit(i-1) then Sammel="1" 'Neuanfang
If Sammel>6 then
MsgBox UV&UV&_
"Im Ordner "" "&Pfad2&" "" sind mehr als 6 Bilder / Sek. !"&_
UV&"Eines dieser Kette ist Bild "&i&" !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
End If
Next
' ************************************
' Zum Abschluss einen Ziel- Ordner für sämtliche Bilder aussuchen :
' *****************************************************************
Wss.Popup UV&UV&VbTab&_
"Bitte den Zielordner der Bilder aussuchen !"&_
" "&_
UV&UV,3,Titel,VbInformation
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder( 0, StrPrompt, BrowseInfo, Root )
On Error Resume Next
Err.Clear
Pfad3=ObF.Self.Path
If Err.Number<>0 then WScript.Quit
Set All=Nothing
' Prüfen, ob der geplante Zielordner wirklich noch völlig leer ist:
' *****************************************************************
Set Data=Fso.GetFolder(Pfad3).Files
Zahl3="0"
For each i in Data
Zahl3=1+Zahl3
Next
If Zahl3>0 then
MsgBox UV&UV&"Der Ordner "&Pfad3&" ist nicht leer !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
' Prüfen, ob der Zielordner von beiden bisherigen verschieden ist :
' *****************************************************************
If (Pfad3=Pfad1 or Pfad3=Pfad2) then
MsgBox UV&UV&"Die Ordner sind leider nicht verschieden !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
'*******************************************************************
'* Die Festplatte "X:\" analysieren, ob genügend Platz da, und *
'* Nachfrage, wenn die benannte Platte nicht genügend Platz hat: *
'*******************************************************************
Ziel=Left(Pfad3,2) 'Die Ziel-Festplatte ermitteln
For each k in Lwk
If k=Ziel then
If k.FreeSpace<Summe+300000000 then '300 MB Rest lassen !
Pfad3=InputBox ( UV&UV&"Das Speichermedium "&_
k&"\ hat nicht genug"&_
UV&"Restanteil an Platz ! ! Bestimmen Sie unten "&_
UV&"den Speicherplatz für sämtliche Bilder neu !"&UV&_
UV, Titel, "F:\Bilder\Gemixt" )
End If
End If
Next
' Eine Kontrollmeldung aller dieser getätigten Ordner - Auswahlen :
' *****************************************************************
Test=MsgBox(UV&"Folgende beiden Bild - Ordner :"&VbCR&Pfad1&_
VbCR&Pfad2&UV&"wurden zum Einsortieren ausgesucht !"&UV&_
"Erneut, aber durchsortiert finden sich die Bilder in:"&VBCR&_
Pfad3&UV&VbCR, VbOkCancel, Titel)
If Test="2" then WScript.Quit
' Sollen alle diese Bilder einen Namen vor deren Nrn. bekommen ?
' ****************************************************************
If Namen="0" then Namen="" 'Keinen Namen vorweg !
' An alle diese Bilder die " Namen " der beiden Kameras anhängen ?
' ****************************************************************
Foto=Kameras
Foto1=""
Foto2=""
If Foto<>"0" then Foto1=Left(Foto,1)
If Foto<>"0" then Foto2=Right(Foto,1)
If Foto="0" then Foto="" 'Keinen Namen anhängen !
' Bei Zeitverschiebung beider Kameras die Verschiebung bestimmen !
' ****************************************************************
If Anders<>"0" then
Tag1="00"
Std1="00"
Min1="00"
Sek1="00"
If Len(Anders)<=5 then
Stelle=InStr(Anders,":")
Min1=Left(Anders,Stelle-1)
Sek1=Right(Anders,2)
End If
If (Len(Anders)>6 and Len(Anders)<=8) then
Std1=Left(Anders,Len(Anders)-6)
Min1=Left(Right(Anders,5),2)
Sek1=Right(Anders,2)
End If
If Len(Anders)>9 then
Stelle=InStr(Anders,":")
Tag1=Left(Anders,Stelle-1)
Std1=Left(Right(Anders,8),2)
Min1=Left(Right(Anders,5),2)
Sek1=Right(Anders,2)
End If
End If
If Anders="0" then Anders="" 'Keine Verschiebung nötig !
' Die Frequenz der CPU ermitteln - wegen der Dauer des Programmes :
' *****************************************************************
CheckKey="HKLM\Hardware\Description\"&_
"System\CentralProcessor\0\~MHz"
Wert0=Wss.RegRead(CheckKey)
'Einen Doppel - Prozessor vorgefunden ?
CheckKey="HKLM\Hardware\Description\"&_
"System\CentralProcessor\1\~MHz"
Wert1=Wss.RegRead(CheckKey)
'Falls ein Doppel - Prozessor vorliegt :
If not Wert1="" then Wert0=Wert0*2
Zeit=Round((14*(Zahl1+Zahl2)/Wert0),1)
' Ein Hinweis auf eine überlange Dauer bei deutlich vielen Bildern :
' ******************************************************************
If Zahl1+Zahl2>150 then
Wss.Popup UV&UV&"Der Vorgang kann bei "&_
Zahl1+Zahl2&" Bildern ca. "&Zeit&" Min. dauern !"&_
" "&UV&UV, 4, Titel, VbCritical
End If
' Auf Sekunde exaktes Datei - Datum im Ordner 1 als Namen wählen :
'*****************************************************************
Set Data=Fso.GetFolder(Pfad1).Files
For each i in Data 's.u. < ==============
Name=Left(i.DateLastModified,19)
' Tag, Monat, Jahr, Std, Min, Sek sämtlicher Aufnahmen ermitteln:
Tag=Left(Name,2)
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2)
'******************************************************************
'* Falls Kamera 2 eine innere Systemzeit nach der Kamera 1 hat, *
'* müssen die Zeiten der Kamera 1 entsprechend durch Addition *
'* angeglichen werden : Sek, Min, Std, Tag, Monat, Jahr ändern! *
'******************************************************************
If Anders<>"" then
Sek=CInt(Sek)+CInt(Sek1) 'Ohne CInt: Anhängen statt Addition!
If Len(Sek)=1 then Sek="0"&Sek
If Sek>59 then
Sek=Sek-60
Min=Min+1
End If
If Len(Sek)=1 then Sek="0"&Sek
If Len(Min)=1 then Min="0"&Min
' ( Problem: "0" wurde bei Addition einfach weggelassen ! )
Min=CInt(Min)+CInt(Min1) 'Ohne CInt: Anhängen statt Addition!
If Len(Min)=1 then Min="0"&Min
If Min>59 then
Min=Min-60
Std=Std+1
End If
If Len(Min)=1 then Min="0"&Min
If Len(Std)=1 then Std="0"&Std
'( Problem: "0" wurde bei Addition einfach weggelassen ! )
Std=CInt(Std)+CInt(Std1) 'Ohne CInt: Anhängen statt Addition!
If Len(Std)=1 then Std="0"&Std
If Std>23 then
Do until Std<24
Std=Std-24
Tag=Tag+1
Loop
End If
If Len(Std)=1 then Std="0"&Std
If Len(Tag)=1 then Tag="0"&Tag
' ( Problem: "0" wurde bei Addition einfach weggelassen ! )
End If
Tag=CInt(Tag)+CInt(Tag1) 'Ohne CInt: Anhängen statt Addition!
If Len(Tag)=1 then Tag="0"&Tag
If Tag>31 and (Monat="01" or Monat="03" or Monat="05" or _
Monat="07" or Monat="08" or Monat="10" or Monat="12") then
Tag=Tag-31
Monat=CInt(Monat)+1
If Monat="13" then
Monat="01"
Jahr=CInt(Jahr)+1
If Len(Jahr)=1 then Jahr="0"&Jahr
End If
If Len(Tag)=1 then Tag="0"&Tag
If Len(Monat)=1 then Monat="0"&Monat
End If
If Tag>30 and (Monat="04" or Monat="06" _
or Monat="09" or Monat="11") then
Tag=Tag-30
Monat=CInt(Monat)+1
If Len(Tag)=1 then Tag="0"&Tag
If Len(Monat)=1 then Monat="0"&Monat
End If
If Tag>28 and (CInt(Jahr) mod 4<>"0") and Monat="02" then
Tag=Tag-28
Monat="03"
If Len(Tag)=1 then Tag="0"&Tag
End If
If Tag>29 and (CInt(Jahr) mod 4="0") and Monat="02" then
Tag=Tag-29
Monat="03"
If Len(Tag)=1 then Tag="0"&Tag
End If
Endg=LCase(Fso.GetExtensionName(i)) 'Datei - Endung
Name=Jahr&Monat&Tag&Std&Min&Sek&"_1."&Endg
'***************************************************************
'* Bilder des 1. Ordners kopieren mit Namen gemäß der Zeit : *
'* Falls gleicher Zeit- Name schon da, an den neuen gleichen *
'* Namen "1" bis "5" anhängen, wird dann dahinter sortiert ! *
'* Es sind also 6 Bilder pro Sekunde dabei hier eingeplant ! *
'***************************************************************
If not Fso.FileExists (Pfad3&"\"&Name) then
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"4_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"4_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"4_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"5_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"5_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
End If
Next 's.o. < ===============
' Auf Sekunde exaktes Datei - Datum im Ordner 2 als Namen wählen :
' ****************************************************************
Set Data=Fso.GetFolder(Pfad2).Files
For each i in Data 's.u. < ============
Name = Left(i.DateLastModified,19)
' Tag, Monat, Jahr, Std, Min, Sek aller der Aufnahmen ermitteln :
Tag=Left(Name,2)
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2)
Endg=LCase(Fso.GetExtensionName(i)) 'Datei-Endung
Name=Jahr&Monat&Tag&Std&Min&Sek&"_2."&Endg
' Die Bilder des 2. Ordners mit ihren Zeit - Namen hinzu kopieren :
' *****************************************************************
' Falls gleicher Zeit - Name da, an den gleichen Namen
' "A", "B" bis "E" anhängen, wird dahinter sortiert !
' Es sind also 6 Bilder pro Sekunde dabei eingeplant !
If not Fso.FileExists (Pfad3&"\"&Name) then
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"D_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"D_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"D_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"E_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"E_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
End If
Next 's.o. < ============
' Alle diese Bilder sammeln, sind vorerst nummeriert nach Auffinden :
' *******************************************************************
Set Ort=Fso.GetFolder(Pfad3).Files
i=1
For each File in Ort
ReDim Preserve Bild(i)
Bild(i)=File
i=i+1
Next
Zahl=i-1
' Alle diese Bilder nach ihrem Datum und der inneren Zeit sortieren :
' *******************************************************************
For i=1 to Zahl
For k=i+1 to Zahl
If Bild(i)>Bild(k) then
xyz=Bild(i)
Bild(i)=Bild(k)
Bild(k)=xyz
End if
Next
Next
' Diese sortierten Bilder neu nummerieren, evtl. einen Namen davor :
' *******************************************************************
i=1
Do until i>Zahl
If i<10 then i="000"&i 'Nr. vierstellig machen
If (i>=10 and i<100) then i="00"&i
If (i>=100 and i<1000) then i="0"&i
If Right(Fso.GetBaseName(Bild(i)),2)="_1" then Fso.MoveFile _
Bild(i), Pfad3&"\"&Namen&i&"_"&Foto1&Right(Bild(i),4)
If Right(Fso.GetBaseName(Bild(i)),2)="_2" then Fso.MoveFile _
Bild(i), Pfad3&"\"&Namen&i&"_"&Foto2&Right(Bild(i),4)
If Foto="" then Fso.MoveFile _
Bild(i), Pfad3&"\"&Namen&i&"_"&Foto2&Right(Bild(i),4)
i=i+1
Loop
' Schluss-Information, dass diese Einsortierung abgeschlossen wurde :
' *******************************************************************
Wss.Popup UV&UV&VbTab&" Das war es ! ! !"&_
" "&UV&UV, 10, Titel, VbInformation
WScript.Quit
http://dieseyer.de • all rights reserved • © 2011 v11.4