http://dieseyer.de • all rights reserved • © 2011 v11.4
'*** 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 )
http://dieseyer.de • all rights reserved • © 2011 v11.4