'*** 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 _ &""&VbCR _ &""&VbCR _ &"Vorgaben abfragen"&VbCR _ &""&VbCR _ &""&VbCR _ &""&VbCR _ &"

"&VbCR _ &"
"&VbCR _ &""&VbCR _ &"

"&VbCR _ &""&VbCR _ &"   "&VbCR _ &"

"&VbCR _ &"
"&VbCR _ &"
"&VbCR _ &"
"&VbCR _ &""&VbCR _ &""&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 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 9CInt(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"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