'*** v7.C *** www.dieseyer.de **************************** ' ' Datei: dateienverschieben_lfd.vbs ' Autor: dieseyer@gmx.de ' Auf: www.dieseyer.de ' ' An die Prozedur ' DateienVerschiebenLFD() arrDateiLst, ZielVerz ) ' wird ein Array mit Dateinamen übergeben. Die Dateien ' werden in das ZielVerzeichnis verschoben. ' ' DateienVerschiebenLFD( arrDateiLst, ZielVerz ) ' arrDateiLst - wenn die Variable kein Array ist, ' wird ein Fehler angezeigt ' ZielVerz - wird erstellt, sofern nicht vorhanden; ' ein Fehler wird zurück gegeben, wenn das Laufwerk ' bzw. der Freigabename eines Netzaufwerks nicht ' vorhanden ist; es muss ein Verz. im Laufwerk ' bzw. im Freigabename angegeben werden. ' ' In den Dateinamen wird vor der Endung eine 3stellige ' Zahl eingefügt; nach der letzten, die vorhandenen ' ist: Sind t_000.txt,t_001.txt, t_002.txt, t_008.txt ' (von t.txt) vorhanden, wird t_009.txt, nicht ' t_003.txt, erstellt. ' ' Existiert t_999.txt, gibt es eine Fehlermeldung und ' die Datei t_999.txt wird überschrieben! ' ' Da für jede Datei geprüft wird, ob es welche mit ' den Zahlen zw. 000 undd 999 gibt, ist das Skript ' sehr langsam. ' ' z.Z. kopiert das Skript - kein Verschieben! ' Es müssen die beiden Zeile getauscht werden: ' fso.MoveFile arrDateiLst( i ), ZwName ' fso.CopyFile arrDateiLst( i ), ZwName ' '********************************************************* Option Explicit ' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~ Const QuellVerz = "D:\dieseyer.neu\css" Const ZielVerz = "D:\temp.zw\zw" ' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~ Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject") Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell") Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log" ' Call LogEintrag( "" ) ' erstellt neue LogDatei Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "059 :: ENDE - " & WScript.ScriptName : WScript.Quit Dim arrDateiLst ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ arrDateiLst = Dateilisteholen( "d:\dieseyer.neu\#include.ph5" ) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' ArrayZeigen( arrDateiLst ) 'LogEintrag "070 :: arrDateiAlt = DateienAlte( arrDateiLst, " & Alter & ", " & ZeitType & " )" & vbCRLF ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DateienVerschiebenLFD arrDateiLst, ZielVerz ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' ArrayZeigen( arrDateiLst ) ' CreateObject("WScript.Shell").Run "notepad " & LogDatei WSHShell.Popup "= = = E N D E = = =", 2, "082 :: " & WScript.ScriptName LogEintrag "084 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )" WScript.Quit '*** v7.C *** www.dieseyer.de **************************** Function DateienVerschiebenLFD( arrDateiLst, ZielVerz ) '********************************************************* ' An die Prozedur ' DateienVerschiebenLFD() arrDateiLst, ZielVerz ) ' wird ein Array mit Dateinamen übergeben. Die Dateien ' werden in das ZielVerzeichnis verschoben. ' ' DateienVerschiebenLFD( arrDateiLst, ZielVerz ) ' arrDateiLst - wenn die Variable kein Array ist, ' wird ein Fehler angezeigt ' ZielVerz - wird erstellt, sofern nicht vorhanden; ' ein Fehler wird zurück gegeben, wenn das Laufwerk ' bzw. der Freigabename eines Netzaufwerks nicht ' vorhanden ist; es muss ein Verz. im Laufwerk ' bzw. im Freigabename angegeben werden. ' ' In den Dateinamen wird vor der Endung eine 3stellige ' Zahl eingefügt; nach der letzten, die vorhandenen ' ist: Sind t_000.txt,t_001.txt, t_002.txt, t_008.txt ' (von t.txt) vorhanden, wird t_009.txt, nicht ' t_003.txt, erstellt. ' ' Existiert t_999.txt, gibt es eine Fehlermeldung und ' die Datei t_999.txt wird überschrieben! ' ' Da für jede Datei geprüft wird, ob es welche mit ' den Zahlen zw. 000 undd 999 gibt, ist das Skript ' sehr langsam. ' ' z.Z. kopiert das Skript - kein Verschieben! ' Es müssen die beiden Zeile getauscht werden: ' fso.MoveFile arrDateiLst( i ), ZwName ' fso.CopyFile arrDateiLst( i ), ZwName Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject") If Right( ZielVerz, 1 ) = "\" Then ZielVerz = Mid( ZielVerz, 1, Len( ZielVerz ) -1 ) LogEintrag "129 :: Start der Function-Prozedur 'Function DateienVerschiebenLFD( arrDateiLst, ZielVerz )'" LogEintrag "130 :: UBound( arrDateiLst ): " & UBound( arrDateiLst ) LogEintrag "131 :: ZielVerz: """ & ZielVerz & "\"" " Dim i, n, z, Tst, Txt, Ttt, ZwLaufw, ZielDatei, ZielName, ZielErw, ZwName ' Laufwerk des ZielVerz auf Existens prüfen ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Txt = "" If Left( ZielVerz, 2 ) = "\\" Then Txt = Mid( ZielVerz, 3 ) If Mid( ZielVerz, 2, 2 ) = ":\" Then Txt = Mid( ZielVerz, 4 ) If Txt = "" Then WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbTab & "'" & ZielVerz & "'", 30, "140 :: ENDE - " & WScript.ScriptName : WScript.Quit Tst = Split( Txt, "\" ) If Left( ZielVerz, 2 ) = "\\" Then ZwLaufw = "\\" & Tst( 0 ) & "\" & Tst( 1 ) If Mid( ZielVerz, 2, 2 ) = ":\" Then ZwLaufw = Left( ZielVerz, 2 ) If fso.FolderExists( ZwLaufw ) Then Else WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbCRLF & vbTab & "'" & ZielVerz & "'" & vbCRLF & vbCRLF & vbTab & "'" & ZwLaufw & "' ist nicht erreichbar!", 30, "148 :: ENDE - " & WScript.ScriptName : WScript.Quit End If ' MsgBox "ZwLaufw: " & ZwLaufw & vbCRLF & " => UBound( Tst ) = " & UBound( Tst ) & vbCRLF & Txt & vbCRLF & ZwLaufw & Txt, , "151 :: " ' Unterverzeichnis(se) zum ZielVerz testen, ggf. erstellen ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Txt = Replace( ZielVerz, ZwLaufw & "\" , "" ) Tst = Split( Txt, "\" ) : i = 0 Txt = ZwLaufw Do If i > UBound( Tst ) Then Exit Do Txt = Txt & "\" & Tst( i ) If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt ) i = i + 1 Loop n = 0 ' Dateien (kopieren ) verschieben ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For i = LBound( arrDateiLst ) to UBound( arrDateiLst ) If fso.FileExists( arrDateiLst( i ) ) Then ZielName = fso.GetBaseName( arrDateiLst( i ) ) ZielErw = fso.GetExtensionName( arrDateiLst( i ) ) ZielDatei = ZielName & "-" & ZielErw Tst = ZielVerz & "\" & ZielName & "." & ZielErw z = 0 ' 3stellige Zahl ermitteln ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Ttt = "-OK" Do If not fso.FileExists( Tst ) AND Ttt = "-OK" Then ZwName = Tst : Ttt = "OK" If fso.FileExists( Tst ) Then Ttt = "-OK" ' : MsgBox Tst, , "181 :: " z = z + 1 : Txt = z : If Len( Txt ) < 3 Then Txt = "0" & Txt : If Len( Txt ) < 3 Then Txt = "0" & Txt Tst = ZielVerz & "\" & ZielName & "_" & Txt & "." & ZielErw If Txt = "999" AND Ttt = "-OK" Then ZwName = Tst : Exit Do If Txt = "999" Then Exit Do Loop If fso.FileExists( ZwName ) Then LogEintrag "188 :: Vorhandene Datei wird überschrieben: """ & ZwName & """ " If fso.FileExists( ZwName ) Then WSHShell.Popup "Vorhandene Datei wird überschrieben: """ & ZwName & """ ", 3, "189 :: " & WScript.ScriptName ' fso.MoveFile arrDateiLst( i ), ZwName fso.CopyFile arrDateiLst( i ), ZwName n = n + 1 ' LogEintrag "194 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & ZielName & "." & ZielErw & """ " LogEintrag "195 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & arrDateiLst( i ) & """ " Else If Len( arrDateiLst( i ) ) > 3 Then LogEintrag "197 :: (" & i & " ) Datei fehlt: " & arrDateiLst( i ) End If Next LogEintrag "201 :: " & n & " von " & UBound( arrDateiLst ) + 1 & " Datei(en) erstellt in: """ & ZielVerz & "\"" " LogEintrag "203 :: Ende der Function-Prozedur 'Function DateienVerschiebenLFD( arrDateiLst, ZielVerz )'" End Function ' DateienVerschiebenLFD( arrDateiLst, ZielVerz ) '*** v7.C *** www.dieseyer.de **************************** Function ArrayZeigen( InArray ) '********************************************************* ' Durch die Prozedur ' ArrayZeigen( InArray ) ' werden von einem Array nur die ersten ' und letzten Elemente angezeigt. Da die MsgBox nur 1024 ' Zeichen anzeigen kann, ist die Anzahl der angezeigten ' Elemente von der Länge der einzelnen Elemente abhängig. Dim TxtOben, TxtUnten, Tst, i, n, o, u Dim Kopf ' für Tests ' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf ' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf For i = LBound( InArray ) to UBound( InArray ) n = UBound( InArray ) - i Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf ) If Tst < 1000 AND n >= i Then ' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF o = i End If n = UBound( InArray ) - i Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) ) Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf ) If Tst < 1000 AND n > i Then ' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten u = n End If If n <=i then Exit For Next Tst = "" If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF Kopf = Replace( Kopf, "O=00000", "O=" & o ) Kopf = Replace( Kopf, "U=00000", "U=" & u ) Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) ) TxtOben = Kopf & TxtOben & Tst & TxtUnten LogEintrag "254 :: " & vbCRLF & TxtOben MsgBox TxtOben , , "255 :: " & WScript.ScriptName End Function ' ArrayZeigen( InArray ) '*** v7.C *** www.dieseyer.de **************************** Function Dateilisteholen( Verz ) '********************************************************* ' Die Prozedur ' Dateilisteholen( Verz ) ' gibt ein Array mit dem kompletten Dateinamen von allen ' Dateien zurück, die in dem übergebenen Verzeichnis ' vorhanden sind. Ein rekursives Auflisten der Datein in ' Unterverzeichnissen erfolgt nicht! Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject") Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) ) ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben LogEintrag "273 :: Ausgeschl: " & Ausgeschl Dim i, oFolders, oFiles, DateiX Set oFolders = fso.GetFolder( Verz ) Set oFiles = oFolders.Files For Each DateiX In oFiles If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben ReDim Preserve DateilisteholenX(i) DateilisteholenX(i) = DateiX ' LogEintrag "282 :: i = " & i & vbTab & Dateilisteholen(i) i = i + 1 End If Next Set oFiles = nothing Set oFolders = nothing Dateilisteholen = DateilisteholenX End Function ' Dateilisteholen( Verz ) '*** v7.C *** www.dieseyer.de **************************** Sub LogEintrag( LogTxt ) '********************************************************* Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject") Dim FileOut ' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log" If LogTxt = "" Then Set FileOut = fso.OpenTextFile( LogDatei, 2, true) FileOut.Close Set FileOut = Nothing Set fso = Nothing Exit Sub End If Set FileOut = fso.OpenTextFile( LogDatei, 8, true) If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt ) ' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt ) If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt ) FileOut.Close Set FileOut = Nothing Set fso = Nothing End Sub ' LogEintrag( LogTxt )