"&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