Sicherung per Rsync.
Optional können weitere Scripte eingebunden werden.
A) Sicherung in ein TrueCrypt-Container (TrueCrypt.vbs) wird benötigt
B) Anwendungen schließen welche Dateien sperrend öffnen.
C) Benuzter darauf hinweisen dass der Wechsel des Speichermediums ansteht.

'......................................................................................
'    rsyncBackupPlus.vbs 3.0
'    Autor: Michael Hölldobler   hoelldobler[at]alant.de
'......................................................................................
'
' Funktionsweise:
' Sicherung von 1 oder mehreren Ordnern In einen Zielordner auf einem NTFS-Laufwerk.
' Mehrere "Schnapschüsse" der Quellen können gesichert werden. Durch die Hardlinks wird
' weniger Speicherplatz verwendet da nur veränderte Quell-Dateien erneut gesichert werden.
' Zu allen anderen Dateien wird nur ein neuer Hardlink erzeugt. Jede Sicherung hat folgenden
' Syntax: ZielLW:\sicherungs-ordner\jahr-monat-tag_stunde_Minute_sekunde\Quellen
' Bestimmte Dateien/Ordner können von der Sicherung ausgeschlossen werden.
' Mit dem Script kann auch das TrueCrypt.vbs Script gestartet werden.
'
' Alle Parameter können über 3 Methoden angegeben werden. Priorität ist A vor B vor C
' A) Über eine ini-Datei
' B) Als Startparameter zu Script
' C) Direkt im Script In der Konfiguration Section
'
' Bekannte Probleme:
'   -- Stages In den Ordner _stufe1, _stufe2, _stufe3 werden manchmal nicht
'      gelöscht. Ein Grund kann sein dass ein Schreibschutz kopiert wurde.
'      Deshalb die Erweiterung um die Funktion -> delSTAGES()
'   -- Bekannte Programme welche ihre Dateien "sperrend öffnen" schließen
'   -- Zielordner umbenennen und Tilde entfernen schlägt machmal fehl daher eine kleine Pause eingebaut
'
' Start-Parameter:
' Alle Parameter immer direkt nach dem Parameterkürzel angeben
' Ziel (DESTINATION) ist jetzt eine Variable
' -dm:\Sicherung_Abteilung_1
'
' Quelle (sourceFolders). Bei mehreren Ordnern die Pfade mit Komma , getrennt angeben
' -s"c:\Dokumente und Einstellungen,d:\sonistiges"
'
' Logdatei für den Hinweis an den Benutzer
' -l"x:\offen\Rync Truecrypt\hint.Log"
'
' Auszuschließende Dateien/Ordner Komma getrennt angeben
' -x"Cache,parent.lock,Temp*,Thumbs.db,*.tmp"
'
' Aufbewahrungs-Versionen
' Versionen (stage0_hourly, stage1_daily, stage2_weekly) sind jetzt Variablen
' -h1   Stunden
' -t14  Tage
' -w4   Wochen
'
' ini-Datei
' Das Script prüft eine ini-Datei mit dem Script-Namen vorhanden ist. Hier kann
' einer davon abweichender angegeben werden.
' -i"c:\xyz\rsyncBackupPlusXYZ.ini"
'
' Generell gilt:
' Alle Start-Parameter mit Leerzeichen kapseln -> "mit Leerzeichen"
' Alle Start-Parameter überschreiben die  im Script angegebenen Parameter
' Prüfen In welchem Pfad Rsync liegt.
'
' Sicherung In ein TrueCrypt-Container. Die Script-Datei TrueCrypt.vbs wird benötigt.
' Die Parameter für TrueCrypt können hier oder In der TrueCrypt.vbs eingtragen werden.
' Das Script TrueCrypt.vbs muss im selben Order wie die rsyncBackupPlus.vbs liegen
'
'
'# Syntax der ini-Datei
'# Hinweise zu korrekten Eingabe
'# Sollte In der Zeichenkette ein Leerzeichen vorkommen,
'# muss die komplette Zeichenkette mit "Anführungszeichen" gekapselt werden!
'# Ein Array Komma getrennt angeben
'[rsyncbackupParameter]
'sourceFolders=
'excludeFiles=
'excludeFiles=
'destination=
'stage0_hourly=7
'stage1_daily=14
'stage2_weekly=4
'userhintLogfile=
'[truecryptParameter]
'truecrypt=False
'truecrypt_volume=
'truecrypt_keyfile=
'truecrypt_password=
' Tip: Sollten die gesicherten Daten per Script geöffnet werden empfielt es sich die
'      TrueCrypt-Parameter im TrueCrypt.vbs abzulegen.
'
'......................................................................................
'... Erweiterung des Scripts von: .....................................................
'... rsyncBackup.vbs 1.04 .................. Autor: Karsten Violka This email address is being protected from spambots. You need JavaScript enabled to view it. ...
'... c't 9/06 .........................................................................
'......................................................................................
'
'--------------------------------------------------------------------------------------
' Bekannte Probleme:
'   -- rsync kopiert keine geöffneten Dateien
'   -- rsync kopiert nur Pfade bis zu einer Länge von 260 Zeichen.
'   -- rsync kopiert keine NTFS-Spezialitäten (Junctions, Streams, Sparse Files)
'
' Skript mit niedriger Priorität starten:
'   start /min /belownormal cscript.exe rsyncBackupPlus.vbs
'--------------------------------------------------------------------------------------
Option Explicit
Dim sourceFolders, excludeFiles, destination, userhintLogfile, stage0_hourly, stage1_daily, stage2_weekly, iniFile
Dim truecrypt, Truecrypt_keyfile, Truecrypt_password, Truecrypt_volume, Truecrypt_Log, Truecrypt_ini
'--------------------------------------------------------------------------------------
'----- Konfiguration ------------------------------------------------------------------
'--------------------------------------------------------------------------------------
' Quellverzeichnisse
'--------------------
' Wichtig: Geben Sie bei den Quellpfaden keinen abschließenden Backslash an, damit
' rsync im Backup-Ziel für jede Quelle einen separaten Unterordner erstellt.
' Können auch als Parameter übergeben werden ; getrennt
' sourceFolders = Array("c:\Dokumente und Einstellungen")
sourceFolders = Array("c:\tmp")
'sourceFolders = Array("BITTE TRAGEN SIE DIE QUELLPFADE IM SKRIPT EIN")
'Ausschluss-Dateien, -Ordner
'---------------------------
'excludeFiles = Array("Cache", "parent.lock", "Temp*", "Thumbs.db", "*.tmp", "Administrator", "Adt", "Aodt", "Backup", "Bdtexp", "Bdtimp", "bfbgif", "Cordoba", "cgdp", "cgdp2", "cgmed", "DALEUV2PDF", "DALEUVPM", "docportal", "Gl", "ibonus", "ifap", "ImpfDoc", "Info", "Install", "kliguide", "Krypto", "kvdt", "Ldt", "Listen", "Log", "obk", "Ppt", "RehaGuide", "sicher", "Source", "sqldrivers", "TM_TMP", "update", "ventario", "vrxclnt", "xsd", "xsl", "*.dll", "*.exe")
' Ausschlussdateien
' XP: Wenn Dokumente und Einstellungen gesichert werden soll
' ----------------------------------------------------------
' Ausschlussordner
' XP: Wenn Dokumente und Einstellungen gesichert werden soll
' ----------------------------------------------------------
'excludeFiles = Array("*.lnk",  "*.Log", "*.tmp", "parent.lock", "NTUSER.DAT", "Tmp*", "Temp*", "Thumbs.db", "UsrClass.dat", "All Users", "*Cache*", "Cookies", "Default User", "Druckumgebung", "IECompatCache", "IETldCache", "LocalService", "NetworkService", "Netzwerkumgebung", "parent.lock", "Recent", "SendTo", "Startmenü", "Temporary Internet Files", "Temp")
' allgemein Ausschließen
excludeFiles = Array("Cache", "parent.lock", "Temp*", "*.tmp", "Thumbs.db", "*.lnk")
' Das Zielverzeichnis sollte sich auf einem mit NTFS formatierten Laufwerk befinden
'-----------------------------------------------------------------------------------
destination = "n:\DundE"
'destination = "m:\test"
'Soll das Backup in ein TrueCrypt-Container abgelegt werden
'--------------------------------------------------------------------------------------------
userhintLogfile = "d:\progs\_Doks_Progs_BSPs\WSH\Rync_Truecrypt\hint.Log"
'Sind die Parameter In einer ini-Dati hinterlegt hier den Pfad angeben
' Wenn die ini-Datei den selben Namen hat wie daas Script wird diese ausgelesen
'------------------------------------------------------------------------------
iniFile = ""

'******************************************************
'Soll im Backup die Verschlüsselung verwenden werden
'---------------------------------------------------
' True Or False
truecrypt = True
If truecrypt Then
'Wenn ein 'truecrypt_volume' angeben ist wird die Verschlüsselung gestartet
'sonst bricht das Script ab !
Truecrypt_volume = ""  '"t:\user\container.tc" "\Device\Harddisk3\Partition1"
' Keyfile und/oder Passwort angeben
'----------------------------------
Truecrypt_keyfile = ""  '"c:\keyfile.txt"
Truecrypt_password = ""
'Die ini-Datei von TrueCrypt.vbs darin einlesen
'----------------------------------------------
' True Or False
Truecrypt_ini = True
End If
'******************************************************

'Anwedungen schließen
'--------------------
' externe close_apps.vbs muss angepasst werden
' Const CLOSEAPPS = False
'----------------------------------------------------------
' Anzahl der aufbewahrten Backups:
stage0_hourly = 1
stage1_daily = 14
stage2_weekly = 4
'Ergänzung: Wenn Sie die Konstante COMPARE_CHECKSUMS auf True setzen,
'ruft das Skript rsync mit dem Schalter --checksum auf (siehe Manpage). Um die Menge
'der Dateien zu ermitteln, die es beim inkrementellen Backup kopiert,
'orientiert sich rsync normalerweise am Zeitpunkt der letzten Änderung. Mit dem gesetzten
'Schalter liest es stattdessen alle Dateien komplett ein, erstellt Prüfsummen und
'vergleicht den tatsächlichen Inhalt.
'Dieser Modus kann aber erheblich mehr Zeit In Anspruch nehmen.
'Die Option kann als Ersatz für die fehlende Verify-Funktion dienen: Wenn Sie In der
'Log-Datei feststellen, dass rsync Dateien erneut kopiert, obwohl sie seit der
'letzten Sicherung nicht geändert wurden, könnten die Dateien auf dem Backupmedium
'verfälscht worden sein.
Const COMPARE_CHECKSUMS = False
'Wenn Sie mehrere Quellordner sichern, die denselben Namen tragen, vermischt rsync
'deren Inhalte standardmäßig im selben Backupverzeichnis. Die Konstante FULL_PATHNAME
'aktiviert den rsync-Parameter "R", der bewirkt, dass rsync für jeden Quellpfad den
'absoluten Pfad im Zielverzeichnis anlegt.
'Wenn Sie beispielsweise zwei Ordner namens "text" auf den Laufwerken E: und F: In
'den Zielordner U:\backup sichern, sieht das Ergebnis etwa so aus:
'
'  U:\backup\2006-05-08~15\cygdrive\e\text
'  U:\backup\2006-05-08~15\cygdrive\f\text
Const FULL_PATHNAME = False
'--------------------------------------------------------------------------------------
'----- ENDE Konfiguration -------------------------------------------------------------
'--------------------------------------------------------------------------------------
Const STAGE1_DAILY_FOLDER = "\_stufe1"
Const STAGE2_WEEKLY_FOLDER = "\_stufe2"
Const STAGE3_MONTHLY_FOLDER = "\_stufe3"
' Konstanten für ADO
Const adVarChar = 200
Const adDate = 7
' Feldnamen fürs RecordSet
Dim rsFieldNames
rsFieldNames = Array("name", "date")
'---- Global verwendete Variablen
Dim fso, wsh, wshEnv, oArgs
'On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set wsh = CreateObject("WScript.Shell")
' Wenn die Umgebungsvariable CYGWIN=NONTSEC gesetzt ist, verändert rsync die Zugriffsrechte
' der Backups nicht. Normalerweise setzt die Cygwin-Bibliothek eigene ACLs,
' um die Unix-Zugriffsrechte abzubilden.
Dim s
Const DUMMY = "¿¿¿"
Set wshEnv = wsh.Environment("process")
wshEnv("CYGWIN") = "NONTSEC"
'---- Die Log-Datei wird im Profilverzeichnis erstellt, etwa:
'---- c:\Dokumente und Einstellungen\Klaus\rsyncBackup.Log
Dim logFile
logFile = wsh.ExpandEnvironmentStrings("%temp%") & "\rsyncBackup.Log"
Dim strSourceFolder, recentBackupFolder, strDateFolder, strDestinationFolder
Set recentBackupFolder = Nothing
Dim strCmd, cmdResult
Set oArgs = WScript.Arguments
' Startparameter verarbeiten
openArgs()
readIniFile()
logAppend (vbCrLf & "-------- Start: " & Now & " --------------------------------------------")
Dim rsyncprog
'Rsync-Pfad herausbekommen
getRsyncFile()
If truecrypt Then
Truecrypt_Log = wsh.ExpandEnvironmentStrings("%temp%") & "\TrueCrypt.Log"
mountTrueCrypt()
s = checkTrueCrypt()
If s <> vbNullString Then
userhintFile (s)
End If
End If
checkFolders()
' mit True als Parameter werden die angegebenen Anwendungen In closeApps notfalls terminiert.
closeApps (False)
strDateFolder = getDateFolderName()
strDestinationFolder = destination & "\~" & strDateFolder ' Zielordner zunächst Tilde voranstellen
Set recentBackupFolder = getRecentFolder(destination)
'-- per Dry-Run prüfen, ob sich der Inhalt eines der Quellordner geändert hat
If sourceChanged() Then
  strCmd = getRsyncCmd(False)
  logAppend ("--- rsync-Befehlszeile:")
  logAppend (strCmd)
  cmdResult = callCmd(strCmd)
  logAppend ("--- Ausgabe von rsync:" & vbCrLf & toCrLf(removePathLines(cmdResult(1))))
  If Len(cmdResult(2)) > 0 Then
    logAppend ("--- Fehlermeldungen:" & vbCrLf & toCrLf(cmdResult(2)))
  End If
  logAppend ("--- Errorlevel: " & cmdResult(0))
  ' Zielordner umbenennen und Tilde entfernen
  WScript.Sleep 2000
  fso.MoveFolder strDestinationFolder, destination & "\" & strDateFolder
Else
  logAppend ("--- nichts Neues")
End If
'-- Backups rotieren und alte Backups löschen
rotate getFolderObject(destination), _
getFolderObject(destination & STAGE1_DAILY_FOLDER), stage0_hourly, "d"
rotate getFolderObject(destination & STAGE1_DAILY_FOLDER), _
getFolderObject(destination & STAGE2_WEEKLY_FOLDER), stage1_daily, "ww"
rotate getFolderObject(destination & STAGE2_WEEKLY_FOLDER), _
getFolderObject(destination & STAGE3_MONTHLY_FOLDER), stage2_weekly, "m"
delSTAGES()
If truecrypt Then
  userhintFile (vbNullString)
  dismountTrueCrypt()
End If
logAppend ("-------- Fertig: " & Now & " --------------------------------------------")
'Kleiner Hinweis an den User
If InStr(1, WScript.FullName, "cscript.exe") Then
  WScript.echo s
Else
  wsh.popup "Ende des Backup-Scripts erreicht", 5, "RsyncBackupPlus-Info (5 Sek.)", vbOKOnly
End If
'---------------------------------------------------------------------------------------
'--- Funktionen ------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
'--- userhintFile() -------------------------------------------------------------------
' Wenn 2 Sicherungslaufwerde im Wechsel eingesetzt werden dass wird immer nach einem LW-Tausch das erste Datum nach der Sicherung eingetragen. So kann die Dauer In Tagen bis zum nächsten Wechsel ausgelesen werden
Function userhintFile(sErr)
  Dim s, f, lwn, dat
  Dim wmi
  On Error Resume Next
  If userhintLogfile = vbNullString Then Exit Function
  Set f = fso.OpenTextFile(userhintLogfile, 1, True)
  If Err.number <> 0 Then
    If Err.number = "76" Then 'Pfad nicht gefunden
      s = "--- Fehlermeldungen:" & vbCrLf & "Pfad der Benutzerhinweis-Datei wurde nicht gefuden." & vbCrLf & userhintLogfile
      wshPopup s, 10, , vbOK
      logAppend (s)
    End If
    '    lwn = DUMMY
    '  On Error Goto 0
  Else
    lwn = f.Readline
    dat = f.Readline
    f.Close
    s = UCase(Left(destination, 1))
    Set wmi = GetObject("winmgmts:\\.\root\cimv2:Win32_LogicalDisk.DeviceID='" & s & ":'")
    s = NZ(wmi.VolumeName, vbNullString) 'Wenn kein Name angebegen ist wird Null zurückgegeben und das ist so nicht auswertbar
    Set f = fso.OpenTextFile(userhintLogfile, 2, True)
    If s <> lwn Then
      f.WriteLine s
      f.WriteLine Date
      f.WriteLine
      ElseIf sErr <> vbNullString Then
      f.WriteLine lwn
      f.WriteLine dat
      f.WriteLine sErr
    End If
    f.Close
  End If
End Function

'--- delSTAGES() -------------------------------------------------------------------
'machmal werden einfach die Stages Ordner nicht geleert. Also weg damit
Function delSTAGES()
  Dim s, destFolder, subfolder
  Const c = "%COMSPEC% /C rd /s /q "
  On Error Resume Next
  s = c & destination & STAGE1_DAILY_FOLDER
  wsh.Run s, 0, True
  s = c & destination & STAGE2_WEEKLY_FOLDER
  wsh.Run s, 0, True
  s = c & destination & STAGE3_MONTHLY_FOLDER
  wsh.Run s, 0, True
  Set destFolder = fso.GetFolder(destination)
  For Each subfolder In destFolder.SubFolders
    If Left(subfolder.Name, 1) = "~" Then
      s = c & destination & "\" & subfolder.Name
      wsh.Run s, 0, True
    End If
  Next
End Function

'--- NZ()-----------------------------------------------------------------------------
'Sollte ein NULL Wert übergeben werden diesen wandlen
Function NZ(Value, ValueIfNull)
  If IsNull(Value) Then
    NZ = ValueIfNull
  Else
    NZ = Value
  End If
End Function

'--- closeApps() ----------------------------------------------------------------------
' hier alle Programme welche geschossen werden sollen
Function closeApps(fForce)
  s = "cscript " & Replace(WScript.ScriptFullName, WScript.ScriptName, vbNullString) & _
  "CloseApps.vbs -f" & fForce
  wsh.Run s, 0, True
End Function

'--- checkTrueCrypt() ----------------------------------------------------------------------
' hat alles mit TrueCrypt geklappt
Function checkTrueCrypt()
  Dim f
  On Error Resume Next
  checkTrueCrypt = vbNullString
  Set f = fso.OpenTextFile(Truecrypt_Log, 1, False)
  If Err.number = 0 Then
    s = f.Readline
    If s = "-" Then
      s = f.Readline
      checkTrueCrypt = s
    Else
      'Sollte das TrueCrypt-Script den LW-Buchstaben geändert haben das Ziel anpassen
      If s <> vbNullString Then destination = s & Right(destination, Len(destination) - 1)
    End If
    f.Close
    Set f1 = fso.GetFile(Truecrypt_Log)
    f1.Delete
  End If
End Function

'--- openArgs() -------------------------------------------------------------------
' Sollten das Scropt
Function openArgs()
  Dim sOA, s, s2, i
  If oArgs.Count = 0 Then
    'Abfangen wenn kein Argument übergeben wurde
  Else
    For i = 0 To oArgs.Count - 1
      On Error Resume Next
      sOA = LCase(oArgs(i))
      s = Left(sOA, 2)
      s2 = Right(sOA, Len(sOA) - 2)
      If Left(s, 1) = """" And Right(s, 1) = """" Then s2 = Mid(s2, 2, Len(s2) - 2)
      Select Case s
        Case "-i": iniFile = s2 'Daten sind In einer ini-Datei abgelegt
        'Rsync Parameter
        Case "-d": destination = s2
        Case "-s": sourceFolders = Split(s2, ",")
        Case "-x": excludeFiles = Split(s2, ",")
        Case "-h": stage0_hourly = s2
        Case "-t": stage1_daily = s2
        Case "-w": stage2_weekly = s2
        Case "-l": userhintLogfile = s2
        'TrueCrypt Parameter
        Case "-v":
          Truecrypt_volume = s2
          truecrypt = True
        Case "-k":
          Truecrypt_keyfile = s2
          truecrypt = True
        Case "-p":
          Truecrypt_password = s2
          truecrypt = True
        Case "-c": truecrypt = True
      End Select
    Next
  End If
End Function

'--- readKeyFile() -------------------------------------------------------------------
' Sollten das Scropt mit einer ini-Datei gestartet werden
' Wenn kein ini-Dateipfad überegeben wird so wir versicht eine ini-Datei mit dem ScriptNamen aufzurufen.
Function readIniFile()
  Dim f, s, keyValue
  If iniFile = vbNullString Then
    iniFile = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, ".", -1, vbTextCompare)) & "ini"
  End If
  Set f = fso.OpenTextFile(iniFile, 1, True)
  If Err.number <> 0 Then
  Else
    Do Until f.AtEndOfStream
    s = f.Readline
    keyValue = Split(s, "=")
    If UBound(keyValue) > 0 Then
      If keyValue(1) <> vbNullString Then
        If Left(keyValue(1), 1) = """" And Right(keyValue(1), 1) = """" Then keyValue(1) = Mid(keyValue(1), 2, Len(keyValue(1)) - 2)
          Select Case keyValue(0)
            Case "sourceFolders":      sourceFolders = Split(keyValue(1), ",")
            Case "excludeFiles":       excludeFiles = Split(keyValue(1), ",")
            Case "destination ":       destination = keyValue(1)
            Case "stage0_hourly":      stage0_hourly = keyValue(1)
            Case "stage1_weekly":      stage1_daily = keyValue(1)
            Case "stage2_weekly":      stage2_weekly = keyValue(1)
            Case "truecrypt":         truecrypt = CBool(keyValue(1))
            Case "truecrypt_volume":   Truecrypt_volume = keyValue(1)
            Case "truecrypt_keyfile": Truecrypt_keyfile = keyValue(1)
            Case "truecrypt_password": Truecrypt_password = keyValue(1)
            Case "userhintLogFile":    userhintLogfile = keyValue(1)
          End Select
        End If
      End If
    Loop
    f.Close
  End If
End Function

'--- getRsyncFile() -------------------------------------------------------------------
Function getRsyncFile()
  Dim s
  rsyncprog = wsh.ExpandEnvironmentStrings("%ProgramFiles%") & "\rsync\rsync.exe" 'c:\Programme
  If Not fso.FileExists(rsyncprog) Then
    rsyncprog = wsh.ExpandEnvironmentStrings("%SystemDrive%") & "\rsync\rsync.exe" 'c:\
    If Not fso.FileExists(rsyncprog) Then
      rsyncprog = Replace(WScript.ScriptFullName, WScript.ScriptName, vbNullString) & "rsync.exe" 'Scriptpfad
      If Not fso.FileExists(rsyncprog) Then
        rsyncprog = Replace(WScript.ScriptFullName, WScript.ScriptName, vbNullString) & "rsync\rsync.exe" 'Scriptpfad
        If Not fso.FileExists(rsyncprog) Then
          s = "Rsync.exe wurde nicht gefunden"
          logAppend ("--- Warnung: " & s)
          criticalErrorHandler "getRsyncFile()", s, 0, ""
        End If
      End If
    End If
  End If
End Function

'--- dismountTrueCrypt() -------------------------------------------------------------------
Function dismountTrueCrypt()
  Dim s, sPath
  'Truecrypt unmounten
  s = "cscript " & Replace(WScript.ScriptFullName, WScript.ScriptName, vbNullString) & "TrueCrypt.vbs -q"
  wsh.Run s, 0, True 'LW dismounten
End Function

'--- mountTrueCrypt() -------------------------------------------------------------------
' cscript mit TrueCrypt.vbs samt Startparametern aufrufen
Function mountTrueCrypt()
  Dim lw, s
  lw = UCase(Left(destination, 1))
  If InStr(1, Truecrypt_keyfile, " ") Then Truecrypt_keyfile = """" & Truecrypt_keyfile & """"
  If InStr(1, Truecrypt_password, " ") Then Truecrypt_password = """" & Truecrypt_password & """"
  If InStr(1, Truecrypt_volume, " ") Then Truecrypt_volume = """" & Truecrypt_volume & """"
  If InStr(1, destination, " ") Then destination = """" & destination & """"
  If Truecrypt_keyfile <> vbNullString Then Truecrypt_keyfile = " -k" & Truecrypt_keyfile
  If Truecrypt_password <> vbNullString Then Truecrypt_password = " -p" & Truecrypt_password
  If Truecrypt_volume <> vbNullString Then Truecrypt_volume = " -v" & Truecrypt_volume
  If Truecrypt_ini Then
    Truecrypt_ini = ""
  Else
    Truecrypt_ini = " -i-"
  End If
  ' TrueCrypt.vbs 0. Quit  1. Laufwerk/Pfad 2. Contaier-File oder Partition 3. Logisch File oder Passwort 4. Filepfad oder PW
  s = "cscript " & Replace(WScript.ScriptFullName, WScript.ScriptName, vbNullString) & _
  "TrueCrypt.vbs -d" & lw & Truecrypt_volume & Truecrypt_keyfile & Truecrypt_password & " -l" & Truecrypt_Log & Truecrypt_ini
  wsh.Run s, 0, True 'LW mounten
End Function

'--- checkFolders() -------------------------------------------------------------------
' Prüft ob die eingetragenen Pfade plausibel sind.
Function checkFolders()
  Dim aSourceFolder
  For Each aSourceFolder In sourceFolders
    If Not fso.FolderExists(aSourceFolder) Then
      criticalErrorHandler "checkFolders()", "Quellordner '" & aSourceFolder & "' existiert nicht.", 0, ""
    End If
  Next
  If Not fso.DriveExists(fso.GetDriveName(destination)) Then
    criticalErrorHandler "checkFolders()", "Ziellaufwerk '" & fso.GetDriveName(destination) & "' nicht gefunden", 0, ""
  End If
  If Not fso.getDrive(fso.GetDriveName(destination)).FileSystem = "NTFS" Then
    logAppend ("--- Warnung: Zielpfad " & destination & " liegt nicht auf einem NTFS-Laufwerk!")
    logAppend ("--- Warnung: rsync erstellt dort keine Hard-Links, sondern vollständige Kopien")
  End If
End Function

'--- sourceChanged() -------------------------------------------------------------------
' Liefert "True", wenn ein Problelauf von rsync ermittelt, dass In den Quellordnern
' seit dem letzten Backup Dateien geändert wurden.
Function sourceChanged()
  Dim strCmd, cmdResult, arrayOutput
  cmdResult = callCmd(getRsyncCmd(True)) ' Kommando mit dryRun aufbauen
  strCmd = removePathLines(cmdResult(1))
  arrayOutput = Split(strCmd, "" & Chr(10) & "", -1, 1)
  '-- wenn schon In der vierten Zeile "sent" steht, hat sich nichts geändert
  If Left(arrayOutput(3), 4) = "sent" Then
    sourceChanged = False
  Else
    sourceChanged = True
  End If
End Function

'--- getRsyncCmd() ----------------------------------------------------------------------
' Baut das rsync-Kommando zusammen. Der Parameter "True" schaltet den dryRun-Modus ein,
' der einen Probelauf startet.
'
' In Version 1.01 habe ich den Schalter "b" wieder entfernt: Er bewirkt, dass
' rsync In neuen Ordnern Backup-Dateien geänderter Dateien vorhält, die auf eine
' Tilde "~" enden. Ohne den Schalter wird die Ausgabe von rsync allerdings sehr
' unübersichtlich: rsync listet dann jedes Mal alle durchsuchten Quellverzeichnisse auf,
' egal, ob es dort etwas Neues gibt. Die Funktion removePathLines() filtert diese
' überflüssigen Zeilen wieder raus.
' Verwendete rsync-Parameter:
'   a   Archiv-Modus   Quellen rekursiv und vollständig kopieren
'   v   Verbose        Ausführliche Ausgabe, listet alle neu übertragenen Dateien auf
'   c                  Optional, rsync berechnet Checksummen und vergleicht damit die
'                      Dateiinhalte, um die Menge der zu kopierenden Dateien zu bestimmen
'   R   relative       Legt im Ziel für jeden Quellordner den vollen Pfad an
'   n   Dryrun
Function getRsyncCmd(dryRun)
  Dim cmd, aSourceFolder, aExcludeFile
  cmd = wsh.ExpandEnvironmentStrings("%comspec%") & " /c " & rsyncprog & " -av"
  If (FULL_PATHNAME = True) Then
    cmd = cmd & "R"
  End If
  If (COMPARE_CHECKSUMS = True) Then
    cmd = cmd & "c"
  End If
  If (dryRun = True) Then
    cmd = cmd & "n"
  End If
  If Not recentBackupFolder Is Nothing Then
    cmd = cmd & " --Link-dest=""" _
    & toCygwinPath(recentBackupFolder.path) & """"
  End If
  For Each aExcludeFile In excludeFiles
    cmd = cmd & " --exclude """ & aExcludeFile & """"
  Next
  For Each aSourceFolder In sourceFolders
    cmd = cmd & " """ & toCygwinPath(aSourceFolder) & """"
  Next
  cmd = cmd & " """ & toCygwinPath(strDestinationFolder) & """"
  getRsyncCmd = cmd
End Function

'--- getDateFolderName()------------------------------------------------------------
' Generiert einen Ordnernamen mit dem aktuellen Datum und der Uhrzeit.
Function getDateFolderName()
  Dim jetzt
  jetzt = Now()
  getDateFolderName = Year(jetzt) & "-" & addLeadingZero(Month(jetzt))_
  & "-" & addLeadingZero(Day(jetzt))_
  & "_"  & addLeadingZero(Hour(jetzt))_
  & "~" & addLeadingZero(Minute(jetzt))
End Function

'--- addLeadingZero(number) -------------------------------------------------------------
' Fügt bei Zahlen < 10 führende Null ein.
Function addLeadingZero(number)
  If number < 10 Then
    number = "0" & number
  End If
  addLeadingZero = number
End Function

'--- getFolderObject(path) -------------------------------------------------------------
' Liefert zum übergebenen Pfad-String ein WSH-Objekt vom Typ Folder
' Wenn das Verzeichnis noch nicht existiert, wird es angelegt.
Function getFolderObject(path)
  If (fso.FolderExists(path)) Then
    Set getFolderObject = fso.GetFolder(path)
  Else
    logAppend ("--- Erstelle Ordner: " & path)
    On Error Resume Next
    Set getFolderObject = fso.CreateFolder(path)
    If Err.number <> 0 Then
      On Error GoTo 0
      criticalErrorHandler "getFolderObject()", "Konnte Zielordner nicht erstellen", Err.number, Err.description
    End If
    On Error GoTo 0
  End If
End Function

'--- toCygwinPath(String) -----------------------------------------------------------------
' Wandelt einen Windows-Pfad In das Format, das Cygwin erwartet
Function toCygwinPath(path)
  Dim driveLetter, newPath
  driveLetter = Left(fso.GetDriveName(path), 1)
  newPath = Replace(path, "\", "/")
  newPath = Mid(newPath, 4)
  toCygwinPath = "/cygdrive/" & driveLetter & "/" & newPath
End Function

'--- toCrLf(String) -----------------------------------------------------------------------
' Ersetzt den von rsync ausgegebenen Unix-Zeilenumbruch (LF)
' durch das Windows-übliche Format (CRLF)
Function toCrLf(strText)
  toCrLf = Replace(strText, vbLf, vbCrLf)
End Function

'--- removePathLines(String) -----------------------------------------------------------------------
' Entfernt alle Zeilen, die auf einen Backslash enden.
' rsync gibt normalerweise alle Pfade aus, die es auf neue Dateien überprüft,
' auch wenn sich dort gar nichts geändert hat. Diese Routine entfernt diese Zeilen,
' damit die Log-Datei übersichtlich bleibt.
Function removePathLines(strText)
  Dim arrayText, line
  arrayText = Split(strText, "" & Chr(10) & "", -1, 1) ' Die Ausgabe muss im Unix-Format
  ' vorliegen, mit LF als Zeilentrenner.
  For Each line In arrayText
    If Not Right(line, 1) = "/" Then
      removePathLines = removePathLines & line & vbLf
    End If
  Next
End Function

'--- logAppend(String) --------------------------------------------------------------------
' hängt den übergebenen Text an die Log-Datei an
Function logAppend(String)
  Const forAppend = 8
  Dim f, errnum
  On Error Resume Next
  Set f = fso.OpenTextFile(logFile, forAppend, True)
  errnum = Err.number
  On Error GoTo 0
  If errnum = 0 Then
    f.WriteLine(String)
    f.Close()
  Else
    Err.Raise 1, "logAppend", "Konnte Logdatei nicht öffnen"
  End If
End Function

'--- getRecentFolder(String) ---------------------------------------------------------------
' Sortiert die im übergebenen Pfad enthaltenen Ordner nach Datum und liefert das jüngste
' Ordner-Objekt zurück
' Parameter: Pfad als String
Function getRecentFolder(path)
  Dim destinationFolder, rs
  Set destinationFolder = getFolderObject(path)
  Set rs = newFolderRecordSet(destinationFolder)
  If Not (rs.EOF) Then
    rs.Sort = "date DESC"    ' absteigend nach Erstellungszeitpunkt sortieren
    rs.MoveFirst
    Set getRecentFolder = fso.GetFolder(rs.Fields("name"))
  Else
    Set getRecentFolder = Nothing
  End If
  rs.Close
  Set rs = Nothing
End Function

'--- newFolderRecordSet(Folder-Objekt) -----------------------------------------------------
' Füllt die Unterordner der übergebenen Folder-Objekts In ein neues RecordSet-Objekt,
' das zum Sortieren verwendet wird.
Function newFolderRecordSet(folder)
  Dim aFolder
  Set newFolderRecordSet = CreateObject("ADODB.RecordSet")
  newFolderRecordSet.Fields.Append "name", adVarChar, 255
  newFolderRecordSet.Fields.Append "date", adDate
  newFolderRecordSet.Open
  For Each aFolder In folder.SubFolders
  If Left(aFolder.Name, 2) = "20" Then ' nur die Datumsordner In die Liste aufnehmen
    newFolderRecordSet.AddNew rsFieldNames, Array(aFolder.path, aFolder.DateCreated)
  End If
  Next
End Function

'--- rotate(fromFolder, toFolder, numberToKeep, diffInterval) ------------------------------
' Verschiebt oder löscht die Backup-Ordner. Für jedes Zeitintervall (Tag, Woche, Monat) wird
' jeweils das zuletzt erstellte Backup archiviert.
'
Function rotate(fromFolder, toFolder, numberToKeep, diffInterval)
  Dim rs, aFolder, lastFolder, i, recentBackup, errNr
  Set rs = newFolderRecordSet(fromFolder)
  If Not (rs.EOF) Then
    rs.Sort = "date DESC"
    rs.MoveFirst
    i = 0
    Do Until rs.EOF
      If i >= numberToKeep Then
        'MsgBox("übrig:" & rs.fields("name"))
        'Das jüngste Backup dieses Datums aus dem toFolder holen. Wenn neuer, ersetzen.
        Set recentBackup = getRecentBackupForDate(toFolder, rs.Fields("date"), diffInterval)
        On Error Resume Next
        If Not recentBackup Is Nothing Then
          ' Wenn das gewählte Backup vom selben Zeitintervall (Tag) ist und
          ' später erstellt wurde, soll es das Backup im Zielordner ersetzen.
          If DateDiff("s", recentBackup.DateCreated, rs.Fields("date")) > 0 Then
            'MsgBox("selber Tag & neuer: bewegen")
            logAppend ("--- bewege " & rs.Fields("name") & " nach " & toFolder.path)
            fso.MoveFolder fso.GetFolder(rs.Fields("name")), toFolder.path & "\"
            If Err.number <> 0 Then
            errNr = Err.number
            On Error GoTo 0
            criticalErrorHandler "rotate()", "Konnte Ordner nicht bewegen", Err.number, Err.description
          End If
          'MsgBox("Vorgänger löschen.")
          logAppend ("--- Vorgänger löschen " & recentBackup)
          fso.DeleteFolder recentBackup, True
          If Err.number <> 0 Then
            On Error GoTo 0
            criticalErrorHandler "rotate()", "Konnte Ordner nicht löschen", Err.number, Err.description
          End If
        Else
          logAppend ("--- lösche " & rs.Fields("name"))
          'MsgBox("selber Tag & älter: weg damit.")
          fso.DeleteFolder fso.GetFolder(rs.Fields("name")), True
          If Err.number <> 0 Then
            On Error GoTo 0
            criticalErrorHandler "rotate()", "Konnte Ordner nicht löschen", Err.number, Err.description
          End If
        End If
      Else
        ' Vom diesem Tag existiert noch kein Backup
        'MsgBox("noch nicht da, bewegen!")
        logAppend ("--- bewege " & rs.Fields("name") & " nach " & toFolder.path)
        fso.MoveFolder fso.GetFolder(rs.Fields("name")), toFolder.path & "\"
        If Err.number <> 0 Then
          On Error GoTo 0
          criticalErrorHandler "rotate()", "Konnte Ordner nicht bewegen", Err.number, Err.description
        End If
      End If
      On Error GoTo 0
      End If
      i = i + 1
      rs.MoveNext
    Loop
  End If
  rs.Close
  Set rs = Nothing
End Function

'--- getRecentBackupForDate(folderObj, aDate, diffInterval) -----------------------------
' Sortiert die Unterverzeichnisse mit Hilfe des ADO RecordSet und liefert
' das das letzte Backup des angegeben Tages/der Woche/des Monats --> diffInterval
Function getRecentBackupForDate(folderObj, aDate, diffInterval)
  Dim rs, exitLoop
  Set getRecentBackupForDate = Nothing
  Set rs = newFolderRecordSet(folderObj)
  If Not (rs.EOF) Then
    rs.Sort = "date DESC"
    rs.MoveFirst
    exitLoop = False
    Do Until rs.EOF Or exitLoop
      If DateDiff(diffInterval, rs.Fields("date"), aDate) = 0 Then
        Set getRecentBackupForDate = fso.GetFolder(rs.Fields("name"))
        exitLoop = True
      End If
      rs.MoveNext
    Loop
  End If
  rs.Close
  Set rs = Nothing
End Function

'--- criticalErrorHandler(source, description, errNumber, errDescription) ---------------
' Kritischen Fehler loggen und Programm abbrechen. (xxx Vor dem Aufruf muss die
' Fehlerbehandlung mit "On Error Goto 0" wieder eingeschaltet werden, damit das Skript
' mit dem neu erzeugten Fehler abbricht. xxx)
' Hinweis PopUp Fenster für 60 Sekunden dann Script beenden
Function criticalErrorHandler(source, description, errNumber, errDescription)
  logAppend ("--- Fehler: Funktion " & source & ", " & description)
  logAppend ("            Err.Number: " & errNumber & " Err.Description:" & errDescription)
  logAppend ("-------- Stop: " & Now & " --------------------------------------------")
  Err.Clear
  wsh.popup description, 60, "Sicherung wird gestoppt", vbExclamation + vbSystemModal
  WScript.Quit
  'Err.Raise 1, source, description
End Function

'--- callCmd(strCommand) ----------------------------------------------------------------
' Führt Kommandozeilenbefehl aus und liefert Array zurück:
' Index 0: Errorlevel
' Index 1: Ausgabe
' Index 2: Fehlerausgabe
Function callCmd(strCommand)
  Dim strTmpFile, strTmpFile2, outputFile, result, strOutput, strOutput2, failed
  strTmpFile = fso.GetSpecialFolder(2) & "\" & fso.GetTempName
  strTmpFile2 = fso.GetSpecialFolder(2) & "\" & fso.GetTempName
  strOutput = ""
  strOutput2 = ""
  strCommand = strCommand & " 1>""" & strTmpFile & """ 2>""" & strTmpFile2 & """"
  result = wsh.Run(strCommand, 0, True)
  If fso.FileExists(strTmpFile2) Then
    If fso.GetFile(strTmpFile2).Size > 0 Then
      Set outputFile = fso.OpenTextFile(strTmpFile2)
      strOutput2 = outputFile.Readall
      outputFile.Close
      deleteInsistently (strTmpFile2)
    End If
  End If
  If fso.FileExists(strTmpFile) Then
    If fso.GetFile(strTmpFile).Size > 0 Then
      Set outputFile = fso.OpenTextFile(strTmpFile)
      strOutput = outputFile.Readall
      outputFile.Close
      callCmd = Array(result, strOutput, strOutput2)
      deleteInsistently (strTmpFile)
    Else
      failed = True
    End If
  Else
    failed = True
  End If
  If failed = True Then
    criticalErrorHandler "callCmd()", "Kommando fehlgeschlagen: " & strCommand _
    & vbCrLf & "--- Fehlermeldung: " & strOutput2, 0, ""
  End If
End Function

'--- deleteInsistently(strFileName)  -----------------------------------------------------
' Auf einigen Testsystemen trat ein Fehler auf, weil die Funktion callCmd() ihre
' temporären Dateien nicht wieder löschen konnte. Vermutlich blockierte gerade ein
' Virenscanner die Datei. Die Funktion deleteInsistently() unternimmt deshalb 10 Versuche,
' die übergebene Datei zu löschen. Wenn ein Versuch fehlschlägt, probiert es das Skript 5
' Sekunden später erneut.
Function deleteInsistently(strFileName)
  Dim noOfTries, successful
  On Error Resume Next
  noOfTries = 0
  successful = False
  While noOfTries < 10 And Not successful
    Err.Clear
    If fso.FileExists(strFileName) Then
      fso.DeleteFile (strFileName)
      If Err.number <> 0 Then
        successful = False
        noOfTries = noOfTries + 1
        logAppend ("--- Warnung: Konnte temporäre Datei " & strFileName & " nicht löschen, Versuch " & noOfTries)
        WScript.Sleep (5000)
      Else
        successful = True
      End If
    Else
      successful = True
    End If
  Wend
  On Error GoTo 0
  If Not successful Then
    logAppend ("--- Warnung: Ich geb's auf.")
  End If
End Function
' --------------------------------------------------
' --- End Function Section -------------------------
' --------------------------------------------------

 

We use cookies on our website. Some of them are essential for the operation of the site, while others help us to improve this site and the user experience (tracking cookies). You can decide for yourself whether you want to allow cookies or not. Please note that if you reject them, you may not be able to use all the functionalities of the site.