Option Explicit
'................................................................................
'    robocopy.vbs
Const cVersion ="0.98.53"
'    Autor: Michael Hölldobler   hoelldobler[at]alant.de
'
' Verwenden Sie dieses Script auf eigene Verantwortung !
'
' Script-Parameter:
' Alle Parameter können über 2 Methoden angegeben werden. Priorität ist A vor B
' A) Über eine ini-Datei. (Wenn Script und ini den selben Namen haben wir die ini gestartet)
' B) Direkt im Script in der Konfigurations-Sektion
'
' Kommandozeilen-Parameter:
' Als Start-Parameter kann der Pfad zu RoboCopy.ini angegeben werden.
' ODER -h bzw. -? um das Dialog-Fenster zum Erstellen der robocopy.ini zu starten
'................................................................................
' ini-Datei mit RoboCopy.hta erstellen
'................................................................................
' Aktuelle Version von HoboCopy bzw. ShadowCopy downloaden
' https://github.com/candera/hobocopy/downloads
' http://www.runtime.org/shadow-copy.htm
' Robocopy ist Bestandteil des 'Windows Server 2003 Resource Kit Tools'
' http://www.microsoft.com/download/en/details.aspx?id=17657
' Command Line Hardlinks
' http://schinagl.priv.at/nt/ln/ln.html

Dim sourceFolders, destination, volumeNameSerialNr, excludeFiles, excludeFolder, includeFileType, touchedFiles, copyFileFlags, retryCopy, waitRetry, phl, hlnk, deleteBefore
Dim separateDrive, bandWidth, skipJunctions, stages, mirror, mirrorStore, mirrorSaved, showShell, hintTime, minFileSize, maxFileSize, roboCopyIni, rotationDays, extendedDelete
Dim userhintFile, vssProg, tcVolume, tcKeyfile, tcPassword, Truecrypt_Log, tcSoftmount, logging, logFile, arraySplitter, PWCrypt
Dim message, closeApps, tcShortcut
Dim emailInfo, emailSubject, emailFrom, emailReceiver, emailUser, emailPassword, smtpServer, scriptErr

'--------------------------------------------------------------------------------
'----- Konfiguration ------------------------------------------------------------
'--------------------------------------------------------------------------------

' Quellverzeichnisse
' Wichtig: Wird bei den Quellpfaden ein abschließenden Backslash angeben so wird
' nur Ordner gesichtert, nicht aber die Unterordner !
'sourceFolders = Array("c:\dokumente", "d:\werte\", "\\server_xyz\ergebnisse ")
' -------------------------------------------------------------------------
sourceFolders = Array("")


' Das Zielverzeichnis
' * Robocopy.vbs (Script) liegt auf dem Ziel-LW dann kann ein ? (Fragezeichen) als LW-Variable eingetragen weden c.B ?:\backup
' * Wenn trueCrypt verwendet und gemoutet wird, ist die Angabe des LW-Buchstabes nicht nötig z.B. \backup
' ----------------------------------------------------------------------------------------------------------------------------
destination = ""

' Ausschlussdateien
' XP: Wenn Dokumente und Einstellungen gesichert werden soll
' OPTIONAL
'excludeFiles = Array("*.lnk",  "*.Log", "*.tmp", "parent.lock", "NTUSER.DAT", "tmp*", "temp*", "thumbs.db", "UsrClass.dat")
' ----------------------------------------------------------
excludeFiles = Array("")

' Ausschlussordner
' XP: Wenn Dokumente und Einstellungen gesichert werden soll
' excludeFolder = Array("All Users", "*Cache*", "Cookies", "Default User", "Druckumgebung", "IECompatCache", "IETldCache", "LocalService", "NetworkService", "Netzwerkumgebung", "parent.lock", "Recent", "SendTo", "Startmenü", "Temporary Internet Files", "Temp")
' ----------------------------------------------------------
excludeFolder = Array("")

' Nur bestimmte Dateitypen packen
' -> "" "*" alle Dateien außer excludeFiles
' -> "*.doc", "*.xls", "*.pdf"
' -------------------------------
includeFileType = Array("")

' Dateien an denen das Datum "geändert am" nicht verändert wird trotz Änderung
' z.B. Truecrypt verhält sich so, da diese Datei nach außen nicht verändert wird.
' Es wird dann nur der letze Zugriff verändert dargestellt
' Ein absoluter Pfad kann angegeben werden
' Oder nur die Datei-Endung (Prefix).
' z.B. ("tc") für TrueCrypt-Container oder ("c:\daten\geheim.tc", "c:\daten\nochgeheimer.tc")
' OPTIONAL
touchedFiles = Array(".tc")
'touchedFiles = Array("d:\x\B_Files.tc")

' LW in eigenen Pfaden speichern
' False oder True (nur wenn Anzahl sourceFolders > 1 und mehrere LW gesichert werden sollen)
' ------------------------------------------------------------------------------------------
separateDrive = True

' Anzahl Backups
' 1 : ohne Datums-Ordner  >=1 mit Datums-Ordner
' ---------------------------------------------
stages = 3

' Wenn mehrere Backup-Ordner vorhanden sind vor oder nach der Erstellung den neuen Backupordner
' den alten löschen. Speziell wenn das Ziel nur wenig freien Platz hat kann diese abhilfe schaffen
' False oder True
' ------------------------------------------------------------------------------------------------
deleteBefore = False

' Quelle Spiegeln
' Nicht mehr vorhandene Dateien in den Quellen werden auch auf dem Ziel-LW gelöscht
' False oder True (True nur möglich wenn stages = 1)
' -------------------------------------------------------------------------------
mirror = False

' Sollte Spiegeln aktiviert sein dann würden nicht mehr vorhandenen Dateien , seit der letzten Sicherung,
' auch im Sicherung-Ordner gelöscht werden. Wenn ein Sicherungsordner für die "gelöschten" angegeben
' wird, werden diese in ein "Lager" verschoben sonst auch in der Sicherung gelöscht.
'--------------------------------------------------------------------------------------------------------
mirrorStore = "mirstore"

' Datei Rechte mit kopieren
' False oder True
' ------------------------
copyFileFlags = False

' Minimale Dateigröße (Byte)
' 0 : keine Einschränkung
'---------------------------
minFileSize = 1

' Maximale Dateigröße (Byte)
' 0 : keine Einschränkung
'---------------------------
maxFileSize = 0

' Netzwerk entlasten
' Pausen in MiliSekunden
' 0 keine .. 1000 -> 1 Sekunde
' ----------------------------
bandWidth = 0

' Orderverknüpfungen (Junktions) überspringen
' (Nicht zu verwechseln mit Softlinks *.lnk)
' True Or False
'--------------------------------------------
skipJunctions = True

' RoboCopy-Info-Fenster während des Kopierens anzeigen
' False : verbergen  True : anzeigen
'-----------------------------------------------------
showShell = False

' Nach abschluß der Sicherung das Berichtsfenster anzeigen
' 0 : Dauerhaft  >0 : Anzeige in Sekunden
'---------------------------------------------------------
hintTime = 20

' Anzahl der Versuche eine Datei zu kopieren wenn diese gesperrt ist
' z.B. wenn ein Virenscanner die Datei gerade prüft
' 0 : kein neuen Versuch starten 3 : mal versuchen
'--------------------------------------------------------------------
retryCopy = 1

' Wartezeit bis zum nächsten Versuch die Datei zu kopieren
' Hat nur eine Auswirkung wenn retryCopy > 0
'------------------------------------------------
waitRetry = 1

' Sollte auf der Sicherungsseite eine Datei vorhanden sein welche lt. excludeFiles für's sichern
' ausgeschlossen ist, wird diese nicht gelöscht falls diese auf der Quell-Seite nicht mehr vorhanden ist.
' Über diesen Schalter können diese ebenfalls gelöscht werden.
' True Or False
'-------------------------------------------------------------------------------------------------
extendedDelete = False

' Wenn die Hardlink.dll nicht vorhanden und in Windows eingebunden ist dann als alternative "fsutil.exe" oder "ln.exe" verwenden
' ------------------------------------------------------------------------------------------------------------------
' 0 : KEINE Hardlinks erzeugen (direkte Kopie)
' Hardlinks erzeugen mit
' 1 : fsutil.exe   (Bestandteil von Windows)
' 2 : ln.exe       (Bezugsquelle http://schinagl.priv.at/nt/ln/ln.html gestestet bis Version 2.650)
' Anmerkung zu fsutil:
' - kann keine Hardlinks bei Netzwerkadressen anlegen \\server\ordner_xy (Dito bei zugewiesenen LW-Buchstaben)
' - kann nur mit Administrator-Rechten gestartet werden
'----------------------------------------------------------------------------
hlnk = 2

' Ziel-LW Name oder SerienNr. bzw. Namen oder SerienNrn. bei Wechsel-Datenträger
' Sollte sich bei Wechseldatenträger der zugewiesene LW-Buchstabe geändert haben, hat kann das Ziel-LW über diese Kennung gefunden werden
' Bei Verwendung von TrueCryt die Benennung/SerienNr des Containers verwenden
' Kann über robocopy.vbs -? herausgefunden werden
' ---------------------------------------------------------------------------------------------------------------------------------------
volumeNameSerialNr = Array("")

' Wenn mehrere Wechselmedien für die Sicherung verwendet werden, den Wechselturnus angeben
' 0 = kein Wechsel der Sicherungsmedien
' ----------------------------------------------------------------------------------------
rotationDays = 0

' Sollte aus irgend welchen Gründen auch immer die Schattenkopie fehlschlagen
' dann kann versucht werden folgende Anwednung zu schließen. Wird der Eintrag GROß geschrieben
' wird das Beenden der Anwedung erzwungen.
' Mögliche Einträge "outlook", "winword", "excel", "powerpoint" bzw. "OUTLOOK", "WINWORD", "EXCEL", "POWERPOINT"
'                   programmxyz.exe (mit Programm.Endung!)
' -----------------------------------------------------------------------------
closeApps = Array("outlook")

' Sind die Parameter in einer ini-Datei hinterlegt hier den Pfad angeben
' Wenn die ini-Datei den selben Namen hat wie das Script wird diese ausgelesen
'------------------------------------------------------------------------------
roboCopyIni = ""

' Sollen die Passwörter in der ini-Datei oder im Script verschlüsselt gespeichert werden
' Das Passwort kann aber mit diesem Script einfach entschlüsselt werden!
' True ->PWs werden verschlüsselt gespeichert  False-> unverschlüsselt
'---------------------------------------------------------------------------------------
PWCrypt = False

' Trennzeichen um Gruppen zu trennen aus der ini-Datei und den Start-Parameter
' ----------------------------------------------------------------------------
' ----------------------------------------------------------------------------
' ----------------------------------------------------------------------------
arraySplitter = ";"
' ----------------------------------------------------------------------------
' ----------------------------------------------------------------------------
' ----------------------------------------------------------------------------

' Hier werden Infos über den Scriptablauf gespeichert.
' 1.Zeile Speichermedium Volume-SerienNr bzw Volue-Name
' 2.Zeile Datum an wenn dieses Speichermedium für die Sicherung verwendet wird
' 3ff. Zeilen Fehlermeldung wenn z.B. das Laufwerk nicht gefunden wurde. Truecrypt Fehler macht
' Soll der Benutzer, wenn 2 Sicherungs-LW verwendet werden, auf den Wechsel hingewiesen werden
' Hinweis-Script läuft auf den Benuzter PC und muss im Dateipfad erreichbar sein.
' --------------------------------------------------------------------------------------------
userhintFile = ""

' Soll über die Sicherung ein Log-File geführt werden
' 0 Kein Bericht erstellen
' Wie lang soll die Log-Datei die Infos behalten
' 1 nur die aktuelle Sicherung loggen
' 2 nur die Sicherungen der Stages sichern
'3 alles Loggen (Datei wird immer größer !)

'-----------------------------------------------------------
logging = 0

' Speicherplatz der Log-Datei. Wenn nichts angegeben wird wird die Log-Datei
' in den destination Ordner angelegt. Der Name kann dann ohne Pfad angegeben werden
' Wird nicht eingetragen wird der ini-Name verwenden sonst der Script-Name ohne Suffix
'-------------------------------------------------------------------------------------
logFile = ""

'************************************************************************************
'***   Sicherung in ein verschlüsselten Datencontainer   ****************************
'************************************************************************************
' Soll das Backup in ein TrueCrypt-Container abgelegt werden

' Wenn ein 'volume' angeben ist wird die Verschlüsselung gestartet. Das Script bricht sonst ab !
' Liegt das volume auf dem Ziel-LW und ist eine Contaiern-Datei so kann ein ? als LW Variable eingetragen werden
' --------------------------------------------------------------------------------------------------------------
tcVolume = ""  '"t:\user\container.tc" "\Device\Harddisk3\Partition1"

' Keyfile und/oder Passwort angeben
' ---------------------------------
tcKeyfile = ""  '"c:\keyfile.txt"
tcPassword = "" '"ist geheim!"

' Truecrypt wird angewiesen jedes mal alle Container zu dismounten und wird dann komplett geschlossen.
' Dies war notwendig da bei einem Wechsel der Speichermedien ohne sie vom System zu entfernen die
' zugewiesenen LW-Buchstaben oft weiterhin blockiert waren und erst nach einem Neustart von Windows wieder
' frei waren. Falls jedoch das Sicherungsmedium nicht gewechselt wird oder der Fehler nicht auftritt kann
' der interne Name des Containers hier angegeben werden und das LW wird nur bei bedarf ge-/dismounted.
' Dann den Datenträger-Namen des gemounten TrueCrypt-Containers eintragen.
' Oder die VolumeSerialNumber. Kann aus bei gemountetem Container über robocopy.vbs -? ausgelesen werden.
' z.B. Array("xyz", "abc") bei Wechseldatenträger
tcSoftmount = Array("")


' um TrueCrypt per Tastenkombination zu beenden sollte in Truecrypt unter Einstellungen -> Systemweite Tastenkombinationen
' eine Tastenkombinationen vergeben werden. (NICHT die WINdows-Taste !) z.B. STRG-ALT-0   ^%0
' UMSCHALT -> +
' STRG -> ^
' ALT -> %
tcShortcut = ""

'************************************************************************************
'***   Schattenkopie auf gesperrte Daten anwenden   *********************************
'************************************************************************************
' ShadowCopy bzw. HoboCopy auf gesperrte Dateien anwenden (z.B. Outlook-Dateien *.pst)
' Hobocopy läuft nicht auf Windows 2003. Auf 2008 wurde es noch nicht getestet
' ShadowCopy hat einen 5 Sekunden Countdown beim Beenden des Programms
' "hobocopy" oder "shadowcopy"
' -----------------------------------------------------------------------------------
vssProg = "shadowcopy"

' Soll eine Info-E-Mail versendet werden
' 0 Nein
' 1 Nach jeder Sicherung
' 2 Medienwechsel
' 3 Medienwechsel und Fehler
' ---------------------------------------
emailInfo = 0

' E-mail Absender Adressse
' z.B Diese E-Mail-Adresse ist gegen Spambots geschützt! JavaScript muss aktiviert werden, damit sie angezeigt werden kann.
' ----------------------------------------------------
emailFrom = ""

' E-Mail Empfänger Adressse
' z.B Diese E-Mail-Adresse ist gegen Spambots geschützt! JavaScript muss aktiviert werden, damit sie angezeigt werden kann.
' "" oder "from" dann wird die E-mail an den Absender versendet
' -------------------------------------------------------------
emailReceiver = ""

' Konto Benuztername bzw. Login-Name
'-----------------------------------
emailUser = ""

' Konto Zugangspasswort
'----------------------
emailPassword = ""

' SMTP-Server-Name auf dem das E-Mail-Konto läuft
' smtp.meimedomain.de
' -----------------------------------------------
smtpServer= ""

' Bei Fehler im Script Info-E-Mail an Entwickler senden
' Wenn beim Auswerten des RoboCopy-Bericht ein neuer Fehler
' gefunden wurden diese Info an den Entwickler weiterleiten
' True Or False
' ----------------------------------------------------------
scriptErr = True

' --------------------------------------------------------------------------------------
' ----- ENDE Konfiguration -------------------------------------------------------------
' --------------------------------------------------------------------------------------

Dim oFS, oWsh, oSap, sTP, oF, oWmi, touchedFilelist, destinationFolders
Dim roboCopyProg, recentBackupFolder, sDateFolder, sDFBase, newBackupFolder, sourceSubfolder
Dim iSF, s, s2, i, j, v, v2, sLog, sLog_, extraFile, sCMD, sSP, smp, fTouchedFiles, duration
Dim trueCryptProg, lw, sm, userGroupList, help, change, vssError, closeAppsErr
Dim sourceFilesErr, sourceFolderErr, destinationFileErr, fCS
Dim delDestinationFileErr,destinationSpaceErr, emailErr, sInfo, fInfo
Dim destinationErr, vssErr, tcErr, scriptErrTxt
Dim rotationHint, infoHint, fNetworkLW, startApps
Dim copyCount, delCount, spaceErrCount
Dim arrReg(6), wmiP(6)

Const cSpace = " "
Const c2Space = "  "
Const cBSlash = "\"
Const cSlash = "/"
Const c2BSlash = "\\"
Const cDQ = """"
Const cD = "."
Const cK = ","
Const cSC = ";"
Const cUL = "_"
Const cAs = "* "

Const cRS = "Robocopy-Sicherung"
Const cAppLog = ".Log"
Const cLLog = " /L /LOG:"
Const cLog = " /LOG:"
Const cRC = "robocopy"
Const cDR = "_dryrun_"
Const cReg = "HKCU\Software\RoboCopyBackup\"
Const cSZ = "REG_SZ"
Const cDel = "DEL /F /Q "
Const cMD = "MKDIR "
Const cMV = "MOVE /Y "
Const cRD = "RD /S /Q "

Const cSDate = 0
Const cVolumeName = 1
Const cVolumeSerialNumber = 2
Const cMediaType = 3
Const cDriveType = 4
Const cFileSystem = 5
Const cServer = 6

scriptdauer(-1)
fCS = Iif(Right(WScript.Fullname, 11) = "cscript.exe", True, False)
userHint "init", 0

Set oFS = CreateObject("Scripting.FileSystemObject")
Set oWsh = CreateObject("WScript.Shell")
Set oSap = CreateObject("Shell.Application")

sLog_ = Array("_FILES_", "_FOLDER_")
extraFile = False
fTouchedFiles = False

'changeNetzwerkPath = False

' Temp-Ordner des Users mit RoboCopy als Datei
sLog = oWsh.ExpandEnvironmentStrings("%temp%") & cBSlash & cRC
sCMD = oWsh.ExpandEnvironmentStrings("%COMSPEC%") & " /C "
sSP = Replace(WScript.ScriptFullName, WScript.ScriptName, vbNullString)

openArgs()
readIniFile()
getFilePath roboCopyProg, cRC & ".exe"
scriptParameter()
robocopyHta()
setHardlink()
regReadRC()
If tcVolume <> vbnullstring Then

mountTrueCrypt()

Else

If checkDestination() Then checkWriting()

End If
checkSource()
userHint "start", 0
checkTouchedFiles()
roboCopy()
If Not deleteBefore And change > 0 And stages > 1 Then folderRotate()
'delMainFolder()
regWriteRC()
startProgs()
userInfo()
If tcVolume <> vbnullstring Then dismountTrueCrypt(True)
dismapNetworkLW()
s = sCMD & cDel & sLog & "*" & cAppLog
oWsh.Run s, 0, True


userHint "End", ""

If showshell Then

s = Replace(sInfo, "$", String(86, "-")) 'Windows 7 bricht nach 86 Zeichen um

s2 = cRS & Iif(hlnk = 0, vbNullString, " mit Hartlinks") & " abgeschlossen"

oWsh.popup s, hintTime, s2, vbOKOnly

End If
'---------------------------------------------------------------------------------------
'--- Funktionen ------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
' !!!
Function CheckExtraFileExcluded(path)

Dim s, i, j  

j = UBound(excludeFiles)

If j > 0 Then    

For i = 0 To j

s = sCMD & cDel & "/S " & wrap(path & cBSlash & excludeFiles(i))

oWsh.Run s, iif(showShell, 1, 0), True

Next  

End If

End Function

'--- CreateHardlink() -------------------------------------------------------------------
Function CreateHardlink(oFolder, oNewFolder)  'Letzte Sicherung

Dim sFiles, sFile, sDateiZiel, sNeuerHardlink, i

Dim oSubfolders, oSubFolder, oNewSubFolder, regEx

On Error Resume Next

userHint "CreateHardlink", vbnullstring

CreateHardlink = False

If hlnk = 2 Then

s = phl & wrap(oFolder.Path) & cSpace & wrap(oNewFolder.path)

i = oWsh.run(s, iif(showShell, 1, 0), True)

   '0  Success. Everything is fine.
   '<0 -1 Errors    

If i = 0 Then CreateHardlink = True

ElseIf hlnk >= 0 Then

Set sFiles = oFolder.Files

    ' Alle Dateien in diesem Ordner abklappern

For Each sFile In sFiles

sNeuerHardlink = oNewFolder.path & cBSlash & sFile.Name

sDateiZiel = oFolder.path & cBSlash & sFile.Name

s = "fsutil hardlink create " & wrap(sNeuerHardlink) & cSpace & wrap(sDateiZiel)

oWsh.run s, iif(showShell, 1, 0), True

Next

Set oSubfolders = oFolder.SubFolders

    'Unterordner abklappern, CreateHardlink rekursiv aufrufen

For Each oSubFolder In oSubfolders

s = oNewFolder.path & cBSlash & oSubFolder.Name

Set oNewSubFolder = oFS.CreateFolder(s)

If Not IsEmpty(oNewSubFolder) Then CreateHardlink oSubFolder, oNewSubFolder

Next

End If

On Error Resume Next

End Function

Function roboCopyParameter()

Dim sF, sXD, sXF, sC, sD, sBW, sMI, sMA, sRC, sWR, sMR

If UBound(includeFileType) > 0 Then

sF = cSpace & Join(includeFileType, cSpace)

Else

If includeFileType(0) = vbNullString Then

sF = vbNullString

Else

sF = cSpace & includeFileType(0)

End If

End If

If UBound(excludeFolder) > 0 Then

sXD = " /XD " & Join(wrap(excludeFolder), cSpace)

Else

If excludeFolder(0) = vbNullString Then

sXD = vbNullString

Else

sXD = " /XD " & excludeFolder(0)

End If

End If

If UBound(excludeFiles) > 0 Then

sXF = " /XF " & Join(wrap(excludeFiles), cSpace)

Else

If excludeFiles(0) = vbNullString Then

sXF = vbNullString

Else

sXF = " /XF " & excludeFiles(0)

End If

End If

If copyFileFlags Then

    'sC = " /COPYALL" 'Inklusive file auditing infomation

sC = " /COPY:DATSO"

Else

sC = vbNullString '/NOCOPY"

End If

If retryCopy = vbnullstring Then 'keine Einschränkung

sRC = " /R:0"

swR = " /W:0"

Else

sRC = " /R:" & retryCopy

swR = " /W:" & waitRetry

End If

sBW = Iif(bandWidth > 0, " /IPG:" & bandWidth, vbNullString)

sMI = Iif(minFileSize > 0, " /MIN:" & minFileSize, vbNullString)

sMA = Iif(maxFileSize > 0, " /MAX:" & maxFileSize, vbNullString)

  'sF muss als 1. Parameter stehen da hier der Dateitypen-Filter direkt nach dem Ziel-Ordner stehen muss
  '/XO  : ältere Dateien überschreiben nicht das Lager.
  '/MIR : Spiegeln. Ein genaues Abbild im Backup-Ordner erzeugen
  '/R:5 /W:2 sollte eine Datei gesperrt sein 5 mal versuchen die Datei zu kopieren und dawischen immer 2 Sekunden warten

roboCopyParameter = sF & sWR & sRC & " /MIR /XO" & sXD & sXF & Iif(skipJunctions = True, " /XJ", vbNullString) & sMI & sMA & sC & sBW

End Function

Function roboCopy()

Dim s, k, f, sDR, sR, sSF, sRBF, sDF, sTP, sTP_, sTP1, sSS, s2, oFF, sN, cpLockedFiles

Dim arrj

Set recentBackupFolder = getRecentFolder(destination)

  ' Einkommentieren wenn der LW nicht angelegt werden soll wenn die Quellpfade auf einem LW liegen
  'checkSeparateSourceDrive()
  'Ziel und Quell-Ordern müssen existieren

change = 0

f = False

cpLockedFiles = True

sTP = sLog & cUL & k & cAppLog

ReDim arrJ(iSF)

ReDim destinationFolders(iSF)

userHint "startDryRun", vbnullstring

For k = 0 To iSF

s = sourceFolders(k)

closeAppsErr = 0

If Left(s, 1) = "-" Then

      'Wenn der Quellpfad nicht existiert wurde ein Minus davor gehängt

Else

If Right(s,  1) = cBSlash Then s = Left(sourceFolders(k), Len(sourceFolders(k))-1)

sSS = splitSource(s)

      'c:, c:\, \, \\

sSF = cSpace & wrap(s) & cSpace

sDFBase = destination & sDateFolder

sDF = sDFBase & sSS(0) & sSS(1) 'wird noch ungekapselt benötigt !

destinationFolders(k) = sDF

If recentBackupFolder Is Nothing Then

s = destination

Else

s = recentBackupFolder.path

End If

sRBF = cSpace & wrap(s & sSS(0) & sSS(1))

sDR = roboCopyProg & sSF & sRBF & roboCopyParameter & iif(sourceSubfolder(k), " /s" , " /LEV:1")

userHint "dryRun", k

arrJ(k) = dryRun(sDR, k, True)

If arrJ(k) > 0 Then

change = change + 1

userHint "update", vbnullstring

ElseIf arrJ(k) < 0 Then

userHint "destErr", "LS"

Else

userHint "no_kopie",  0

End If

End If

Next

If showShell Then

sN = " /TEE"

Else

sN = vbnullstring

End If

sN = sN & " /NDL /NS /NJS /NJH" & cLOG

If change > 0 Then

userHint "startRoboRun", vbnullstring

If deleteBefore And stages > 1 Then folderRotate()

For k = 0 To iSF

s = sourceFolders(k)

If Left(s, 1) = "-" Then

Else

If arrJ(k) < 0 Then

          'nicht genügend Speicherplatz

Else

If Right(s,  1) = cBSlash Then s = Left(sourceFolders(k), Len(sourceFolders(k))-1) 'Abschließendes \ löschen

sSS = splitSource(s)

          'c:, c:\, \, \\

sSF = cSpace & wrap(s) & cSpace

sDFBase = destination & sDateFolder ' Zielordner zunächst Tilde voranstellen

          'sDF = sDFBase & sSS(0) & sSS(1) 'wird noch ungekapselt benötigt !

sDF = destinationFolders(k)

sR = roboCopyProg & sSF & wrap(sDF) & roboCopyParameter & iif(sourceSubfolder(k), " /s" , " /LEV:1")

userHint "RoboRun", k

If Not recentBackupFolder Is Nothing Then

On Error Resume Next

Set newBackupFolder = getFolderObject(sDFBase)

On Error Goto 0

If Err.Number > 0 Then

Err.Clear

userHint "destErr", "LW_P"

Else

If hlnk > 0 And Not newBackupFolder Is Nothing Then                

                'Erst einmal eine volle Hard-Kopie aller Dateien machen. Noch nichts eleganteres gefunden.

If Not f Then

f = CreateHardlink(recentBackupFolder, newBackupFolder)                  

End If

If arrJ(k) > 0 Then                  

delToUpdate sR, sourceFolders(k), sDF, sSS, k, True

End If

Else

delToUpdate sR, sourceFolders(k), sDF, sSS, k, False

End If

End If

Else

delToUpdate sR, sourceFolders(k), sDF, sSS, k, False

End If

If arrJ(k) > 0 Or (hlnk = 0 And arrJ(k) = 0 And stages > 1) Then

userHint "kopie", sourceFolders(k)

s = sR & sN & sLog & cUL & k & cAppLog

j = oWsh.Run(s, iif(showShell, 1, 0), True)

Else

j = 0

userHint "skip", vbnullstring

End If

End If

        ' RoboCopy Exit-Codes
        '0  No errors occurred And no files were copied.
        '1  One of more files were copied successfully.
        '2  Extra files Or directories were detected. Examine the Log file for more information.
        '4  Mismatched files Or directories were detected. Examine the Log file for more information.
        '8  Some files Or directories could Not be copied And the retry limit was exceeded.
        '9  dito 8
        '16 Robocopy did Not copy any files.  Check the command line parameters And verify that Robocopy has enough rights To write To the destination folder.

If j >= 2 Then '8

        ' 1 Prüfen ob user Administrator ist. Wenn ja dann Shadowcopy und danach CloseApp mit k = k-1
        ' sonst gleich closeAppication mir k = k-1
        ' CloseApp mit k = k-1 vor  damit

sTP = sLog & cUL & k & cAppLog

copyLockedFiles sTP, sSS, k

If vssError = 1 Or closeAppsErr = 1 Then

If closeAppication() Then

resetErrFiles(k)

k = k - 1

End If

End If

End If

End If

Next

Else

userHint "nochange", vbNullString

End If

End Function

'Zerlegt den Pfad in seine Bestandteile
Function splitSource(sPath)

Dim sd, j

sd = Array(vbnullstring, vbnullstring)

  'c:, c:\, \, \\

If Left(sPath, 2) = c2BSlash Then

j = InStr(3, sPath, cBSlash )

If j = 0 Then 'c: Nur LW

sd(1) = vbNullString

Else

sd(1)= Right(sPath, Len(sPath) - j + 1)

End If

sd(0) = Iif(separateDrive, Mid(s, 2, j -2 ) & cUL, vbNullString)

Else

j = InStr(1, sPath, cBSlash)

If j = 0 Then 'c: Nur LW

sd(1) = vbNullString

Else

sd(1) = Right(sPath, Len(sPath) - j + 1)

End If

sd(0) = Iif(separateDrive, cBSlash & Left(sPath, 1) & cUL, vbNullString)

End If

splitSource = sd

End Function


' Testlauf von Robocopy um zu ermitteln ob und was verädert ist zur letzen Sicherung
' in die Datei robocopy_dryrun_xx.Log werden
Function dryRun(sR, nr, fL)

Dim i, j, fF, fB, sL, si, sN, oFF, same, gleich, sT

  '/NFL : keine einzelnen Dateien in die Log-Datei schreiben
  '/NDL :      "            Ordner       "
  '/NJH : No Job Header Keine Kopf-Daten
  '/L   : nur Logdatei anlegen

dryRun = 0

fF = False

fB = False

sL = cDR & nr & cAppLog

same = " same" & chr(9)

gleich = " Gleich" & chr(9)

If fL Then

sN = " /NS /NP /NDL /NJH"

Else

sN = " /NFL /NDL /NJH"

End If

s = sR & iif(fTouchedFiles, " /V", vbnullstring) & sN & cLLog & wrap(sLog & sL)

oWsh.Run s, 0, True

  'oem2ansi(sLog & sL) nicht notwendig

Set oFF = oFS.opentextfile(sLog & sL, 1, True)

Do

s = Replace(LTrim(oFF.ReadLine), " :", ":")

  'im Log-File nach der Zeile mit Files, bzw. Dateien suchen
    'If InStr(1, s, " *EXTRA File ") > 0 Or InStr(1, s, " *EXTRA Datei") > 0 Then
    'noch nicht

If InStr(1, s, "Files:") Or InStr(1, s, "Dateien:") Then 'XP Or Vista, 7

s = Replace(s, Chr(9), cSpace) 'tab -> " "

Do

s = Replace(s, c2Space, cSpace) '"  " -> " "

Loop Until InStr(1, s, c2Space) = 0

v = Split(s, cSpace)

      'Wenn gefunden dann steht in der 3. Spalte wie viele Dateien kopiert werden und in der 7. wie viele Extra sind

If CLng(v(2)) > 0 Or CLng(v(6)) > 0 Then dryRun = 1

fF = True  'Copied

ElseIf InStr(1, s, "Bytes:") Or InStr(1, s, "Bytes:") Then 'XP Or Vista, 7

On Error Resume Next

If Left(destination, 2) = c2BSlash Then

        'Im Netzwerk-Pfad Restspeicherplatz nicht auszulesen

ElseIf Mid(destination, 2 ,1) = ":" Then

s = Replace(s, Chr(9), cSpace) 'tab -> " "

Do

s = Replace(s, c2Space, cSpace) '"  " -> " "

Loop Until InStr(1, s, c2Space) = 0

        'Sonst werden es zu viele Felder im Array

s = Replace(s, " g", "g")

s = Replace(s, " m", "m")

s = Replace(s, " k", "k")

s = Replace(s, " b", "b")

v = Split(s, cSpace)

        'Copied

s = Right(v(2), 1)

If s <> "0" Then

s2 = Left(v(2), Len(v(2)) - 1)

          'si = stringToSingle(s2)

si= CSng(Replace(s2, cD, cK))

si = convertToByte(si, s)

End If

If mirror And mirrorStore <> vbnullstring Then

          'Daten werden nur verschoben daher wird der Speicherplatz noch benötigt

Else

          'Extra Files

s = Right(v(6), 1)

If s <> "0" Then

s2 = Left(v(6), Len(v(6)) - 1)

  '          s2 = stringToSingle(s2)

s2 = CSng(Replace(s2, cD, cK))

s2 = convertToByte(s2, s)

si = si - s2

End If

End If

Set oF = oFS.drives(Left(destination , 2))

v = oF.availablespace

If v = 0 Then

'          dryRun = -1 * dryRun

dryRun = 1 * dryRun

ElseIf v < si Then

If si / v > 1.01 Then 'Die zu speichernde Menge benötigt 5% mehr Platz als zur Verfügung steht. Also Abbrechen da sonst die Routine zu lang benötigt.

'            dryRun = -1 * dryRun

dryRun = 1 * dryRun

End If

End If

End If

Set oF = Nothing

On Error Goto 0

fB = True

ElseIf fTouchedFiles Then

If InStr(1,s, same) > 0 Or InStr(1,s, gleich) > 0 Then

For i = 0 To UBound(touchedFiles)

sT = touchedFiles(i)

If sT <> vbnullstring Then

If Right(s, Len(sT)) = sT Then

s = Trim(Right(s, Len(s) - InStrRev(s, chr(9), -1, vbTextCompare)))

If touchFile(s, nr) = True And dryRun >= 0 Then dryRun = 1

End If

End If

Next

End If

End If

Loop Until (fF = True And fB = True) Or oFF.AtEndOfStream

oFF.Close

Set oFF = Nothing

End Function

' Einträge Prüfen und ggf. anpassen oder Schalter setzen
Function checkTouchedFiles()

Dim i, j, s

j = UBound(touchedFiles)

i = UBound(sourceFolders)

ReDim touchedFilelist(i, 0)

For i = 0 To j

s = touchedFiles(i)

If s = vbnullstring Then

Else

If Left(s, 1) <> cD Then touchedFiles(i) = cD & s

fTouchedFiles = True

End If

Next

End Function

' Bei bestimmten Programmen wird das "Geändert am Datum" nicht verändert. z.B. durch TrueCrypt.
' Bei Dateien das Datum der letzten Änderung auf letzten Zugriff setzen.
' Muss gemacht werden damit RoboCopy diese Dateien sichert.
Function touchFile(filePath, nr)

Dim sF, sP, i, j, oNS, oFX

On Error Resume Next

touchFile = False

i = InStrRev(filePath, cBSlash, -1, vbTextCompare)

sF = Right(filePath, Len(filePath) - i)

sP = Left(filePath, i - 1)

Set oF = oFS.getfile(filePath)

If Err.Number = 0 Then

'    WScript.echo "DateLastModified  "  & oF.DateLastModified
'    WScript.echo "DateLastAccessed  "  & oF.DateLastAccessed

If oF.DateLastModified < oF.DateLastAccessed Then

Set oF = Nothing

Set oF = oSap.NameSpace(sP)

Set oFX = oF.ParseName(sF)

oFX.ModifyDate = Now()

Set oFX  = Nothing

touchFile = True

copyCount(nr) = copyCount(nr) + 1 ' Zähler erhöhen

'      j = UBound(touchedFilelist, 2)
'      WScript.echo "  ---  2  " & UBound(touchedFilelist, 2)
'      WScript.echo "  ---  1  " & UBound(touchedFilelist, 1)
'      WScript.echo "  ---  0  " & UBound(touchedFilelist)
'

'      for i = 0 To j
'        If touchedFilelist(nr, i) = vbnullstring then
'          touchedFilelist(nr, i) = filePath
'          Exit For
'        End If
'      Next
'      If i = j then
'        j = UBound(sourceFolders)
'        ReDim preserve touchedFilelist(j, i + 1)
'      End If

End If

Else

Err.Clear

End If

On Error Goto 0

Set oF = Nothing

End Function

' Es wurde mit CreateHardlink() eine Hardlink-Kopie der letzten Sicherung erstellt
' RoboCopy vergleicht jetzt die Dateien nach Veränderungen.
' Die veralteten Dateien im neuen Zielorder müssen gelöscht werden.
Function delToUpdate(sR, sSF, sDF, sSS, nr, fN)

Dim f, s, s2, sP, sF, sMS, i, parentFolder, subFolder, iExtra, v

On Error Resume Next

userHint "delToUpdate", nr

If mirror And mirrorStore <> vbnullstring Then

i = checkPath(mirrorStore)

If i >= 2 Then

sMS = mirrorStore

Else

sMS = destination & cBSlash & mirrorStore

End If

If Not oFS.folderexists(sMS) Then

s = sCMD & cMD & wrap(sMS)

oWsh.Run s, 0, True

End If

End If

iExtra = 0

s = sLog & cDR & nr & cAppLog

oem2ansi(s)

Set oF = oFS.opentextfile(s)

Do

s = Replace(LTrim(oF.readline), " :", ":")

If InStr(1, s, "Files:") Or InStr(1, s, "Dateien:") Then 'XP Or Vista, 7

s = Replace(s, Chr(9), cSpace)

Do

s = Replace(s, c2Space, cSpace)

Loop Until InStr(1, s, c2Space) = 0

v = Split(s, cSpace)

ElseIf InStr(1, s, "  Newer  ") Or InStr(1, s, "  Neuer  ") And fN Then

i = InStrRev(s, chr(9), -1, vbTextCompare) 'nach letztem Tab suchen

s2 = Right(s, Len(s) - i)

i = InStr(1, s2, chr(13)) 'nach x% suchen wird angehhängt wenn Schalter /NP nicht gesetzt ist

If i > 0 Then

s2 = Left(s2, i)

End If

s = Replace(s2, sSF, sDF)

If InStr(1, s, c2BSlash) > 0 Then

Set f = oFS.GetFile(s)

f.Delete

Else

s2 = sCMD & cDel & wrap(s)

i = oWsh.Run( s2, 0, True)

End If

ElseIf mirror And mirrorStore <> vbnullstring Then

      'gelöschte Datei sichern

If InStr(1, s, " *EXTRA File ") > 0 Or InStr(1, s, " *EXTRA Datei") > 0 Or InStr(1, s, "*named file") > 0 Or InStr(1, s, "*Benannte D") > 0 Then

i = InStrRev(s, chr(9), -1, vbTextCompare) 'nach letztem Tab suchen

s2 = LCase(Right(s, Len(s) - i))

i = InStr(1, s2, chr(13)) 'nach x% suchen wird angehhängt wenn Schalter /NP nicht gesetzt ist

If i > 0 Then s2 = Left(s2, i)

iExtra = iExtra + 1

        's2 = Replace(s2, Lcase(sDFBase), Lcase(sSF & sSS(0) & sSS(1) & cBSlash & mirrorStore), 1)
        's2 = Replace(s2, s, sDFBase & cBSlash & mirrorStore)
        'sP = Left(s2, InStrRev(s2, cBSlash, -1) - 1, vbTextCompare)

i = InStr(1, s2, sSS(0) & sSS(1))

If i > 0 Then

sF = Right(s2, Len(s2) - i + 1)

          's = destination & cBSlash & mirrorStore

i = InStrRev(sF, cBSlash, -1, vbTextCompare)

If i > 0 Then

sP = Left(sF, i - 1)

If Not oFS.folderexists(sMS & sP) Then

sP = sCMD & cMD & wrap(sMS & sP)

oWsh.Run sP, 0, True

WScript.sleep 5

End If

s = sCMD & cMV & wrap(s2) & cSpace & wrap(sMS & sF)

oWsh.Run s, 0, True

mirrorSaved = mirrorSaved + 1

End If

End If

End If

Else

If InStr(1, s, "*named file", vbTextCompare) > 0 Or InStr(1, s, "*Benannte D", vbTextCompare) > 0 Then '

        'diese Dateien sind durch den Dateifilter ausgeklammert und werden durch Robocopy ausgeklammert

i = InStrRev(s, chr(9), -1, vbTextCompare) 'nach letztem Tab suchen

s2 = LCase(Right(s, Len(s) - i))

i = InStr(1, s2, chr(13)) 'nach x% suchen wird angehhängt wenn Schalter /NP nicht gesetzt ist

If i > 0 Then s2 = Left(s2, i)

s = sCMD & cDel & wrap(s2)

oWsh.Run s, 0, True

ElseIf (InStr(1, s, " *EXTRA File ") > 0 Or InStr(1, s, " *EXTRA Datei") > 0) And stages = 1 Or (stages > 1 And hlnk = 1) Then

        'diese Dateien sind durch den Dateifilter ausgeklammert und werden durch Robocopy ausgeklammert

iExtra = iExtra + 1

End If

End If

Loop Until oF.AtEndOfStream

oF.Close

Set oF = Nothing

For i = 0 To UBound(touchedFilelist, 2)

s2 = touchedFilelist(nr, i)

If s2 <> vbnullstring Then

s = Replace(s2, sSF, sDF)

If InStr(1, s, c2BSlash) > 0 Then

Set f = oFS.GetFile(s)

f.Delete

Else

s2 = sCMD & cDel & wrap(s)

oWsh.Run s2, 0, True

End If

copyCount(nr) = copyCount(nr) + 1

End If

Next

If Not sourceSubfolder(nr) Then

If oFS.Folderexists(sDF) Then

Set parentFolder = oFS.GetFolder(sDF)

For Each subFolder In parentFolder.SubFolders

s = subFolder.path

forceDelete s

Next

End If

End If

If iExtra < CLng(v(6)) Then CheckExtraFileExcluded sDF    

On Error Goto 0

End Function

' Es wurde mit CreateHardlink() eine Hardlink-Kopie der letzten Sicherung erstellt
' Mit delToUpdate() wurden die neueren Dateien dann gelöscht damit diese kopiert werden
' Sollte jedoch die Quellverzeichnisse verändert worden sein so werden die nicht mehr verwendenten Pfade gelöscht
' Wenn der gänderte Quell-Pfad ein Unterorder des alten ist kann dies nicht korrigiert werden
' Bis jetzt nur mit LW getestet. Nicht auf Netzwerkpfaden
Sub delMainFolder()

Dim i, j, s, sSS, parentFolder, subFolder, delFolder, sPD, sSD, sSDL

On Error Resume Next

If newBackupFolder = vbNullString Then Exit Sub

If Not newBackupFolder Is Nothing Then

ReDim delFolder(0)

For i = 0 To UBound(sourceFolders)

sP = recentBackupFolder.path '"D:\backup\2010-10-01_11~23"

sSS = splitSource(sourceFolders(i))

sSD = sP & sSS(0) & sSS(1) ' Quelle in Ziel transformiert

sSDL = sSDL & cSC & sSD

sPD = sP & sSS(0) & Left(sSS(1), InStrRev(sSS(1), cBSlash, -1, vbTextCompare) - 1)

Set parentFolder = oFS.GetFolder(sPD)

For Each subFolder In parentFolder.SubFolders

s = subFolder.path

If InStr(1, sSDL, s) Then

For j = 0 To UBound(delFolder)

If sSD = delFolder(j) Then delFolder(j) = vbnullstring

Next

Else

For j = 0 To UBound(delFolder)

If delFolder(j) = vbnullstring Then

delFolder(j) = subfolder.path

Exit For

End If

Next

If j = UBound(delFolder) Then ReDim Preserve delFolder(j + 1)

End If

Next

Next

    ' Jetzt wirklich die obsoleten Ordner löschen

For j = 0 To UBound(delFolder) - 1

s = delFolder(j)

If mirror Then

If s <> vbnullstring Then oFS.deletefolder(s)

If Err.Number > 0 Then

Err.Clear

s = sCMD & cRD & s

oWsh.Run s, 0, True

End If

End If

Next

End If

On Error Goto 0

End Sub

Function copyLockedFiles(sTP, sSS, nr)

Dim s, f, i, j, k, l, jw, vz, hc, sf, so, sc, sd

Dim lbFo, lbFi, ldFi, ddFi, lbf

Dim lz 'gsperrtes Ziel

Dim s1

Const cE = "ERROR: RETRY LIMIT EXCEEDED."

Const cF = "Fehler: Die maximale Anzahl von Wiederholungsversuchen wurde überschritten."

On Error Resume Next

Set f = oFS.OpenTextFile(sTP, 1, False)

If Err.Number > 0 Then

Err.Clear

Exit Function

Else

lbFi = False

lbFo = False

ldFi = False

lbf = False

lbFi = False

ddFi = False

l = False

lz = False

vz = False

Do Until f.AtEndOfStream

s = oem2ansiTxt(Trim(f.Readline))

If s = vbnullstring Then

        'sf = vbnullstring

ElseIf InStr(1, s ," ERROR ") Or InStr(1, s ," FEHLER ") Then

        'Backup-Ordner Lesefehler

If InStr(1, s ," ERROR 32 (0x00000020) Copying File ") > 1 Then 'Englisch und XP

sf = Right(s, Len(s) - 55)

lbFi = True

ElseIf InStr(1, s ," FEHLER 32 (0x00000020) Folgende Datei wird kopiert ") > 1 Then 'Vista, 7

sf = Right(s, Len(s) - 71)

lbFi = True

ElseIf InStr(1, s ," ERROR 33 (0x00000021) Copying File ") > 1 Then 'Englisch und XP

sf = Right(s, Len(s) - 55)

lbFi = True

ElseIf InStr(1, s ," FEHLER 33 (0x00000021) Folgende Datei wird kopiert ") > 1 Then 'Vista, 7

sf = Right(s, Len(s) - 71)

lbFi = True

        'Keine Leserechte im Backupordner

ElseIf InStr(1, s ," ERROR 5 (0x00000005) Copying File ") > 1 Then 'XP

sf = Right(s, Len(s) - 54)

lbFi = True

ElseIf InStr(1, s , " FEHLER 5 (0x00000005) Folgende Datei wird kopiert ") > 1 Then 'Vista, 7

sf = oem2ansiTxt(Right(s, Len(s) - 70))

lbFi = True

        'Kein Lesesrechte im Quellordner  

ElseIf InStr(1, s ," FEHLER 5 (0x00000005) Zugriff auf Quellverzeichnis ") > 1 Then 'Vista, 7

sf = Right(s, Len(s) - 71)

lbFo = True        

ElseIf InStr(1, s ," ERROR 5 (0x00000005) Scanning Source Directory ") > 1 Then 'XP

sf = Right(s, Len(s) - 67)

lbFo = True

        ' Gesperrtes Backupordner daher konnte die Datei nicht kopiert werden

ElseIf InStr(1, s , " ERROR 5 (0x00000005) Changing File Attributes ") Then

If Not ldFi Then

sf =   Trim(Right(s1, Len(s1) - InStrRev(s1, chr(9), -1, vbTextCompare)))

           'sf = Right(s, Len(s) - 66) & Trim(Right(s1, Len(s1) - InStrRev(s1, chr(9), -1, vbTextCompare)))

End If

ldFi = True

ElseIf InStr(1, s , " FEHLER 5 (0x00000005) Dateiattribute werden geändert ") Then  

          'In Vista, 7 steht hier nur der Ordner. Eine Zeile zuvor wird keine Datei eingetragen wie in XP    

        ' Kein Leserechte im Backupordner

ElseIf InStr(1, s , " FEHLER 5 (0x00000005) Zugriff auf Zielverzeichnis ") > 1 Then 'Vista, 7

If Not ldFi Then

sf =   Trim(Right(s1, Len(s1) - InStrRev(s1, chr(9), -1, vbTextCompare)))

End If

ldFi = True          

        ' Backup-Ordner  Zugriff verwehrt      

ElseIf InStr(1, s ," ERROR 5 (0x00000005) Scanning Destination Directory ") > 1 Then 'XP          

ElseIf InStr(1, s ," FEHLER 5 (0x00000005) Zielverzeichnis wird überprüft ") > 1 Then

        ' Kein Platz im Backup-LW

ElseIf InStr(1, s ," ERROR 112 (0x00000070) Copying File ") > 1 Then 'Creating Destination Directory

sf = Right(s, Len(s) - 56)

vz = True

ElseIf InStr(1, s ," FEHLER 112 (0x00000070) Folgende Datei wird kopiert ") > 1 Then 'Vista, 7

sf = Right(s, Len(s) - 72)

vz = True

        ' Löschen von "extra" Dateien

ElseIf InStr(1, s , " ERROR 32 (0x00000020) Deleting Extra File ") Then

sf = Right(s, Len(s) - 62)

ddFi = True

ElseIf InStr(1, s , " FEHLER 32 (0x00000020) Zusätzliche Datei wird gelöscht ") Then '

sf = Right(s, Len(s) - 75)

ddFi = True

Else

If scriptErr Then scriptErrTxt = scriptErrTxt & vbcrlf & s & vbcrlf

End If

End If

If lbFi Then

If s = cE Or s = cF Or retryCopy = 0 Then

j = UBound(sourceFilesErr, 2)

For i = 0 To j

If sourceFilesErr(nr, i) = sf Then

lbFi = False

Exit For

End If

Next

If lbFi Then

sourceFilesErr(nr, j) = sf

copyCount(nr) = copyCount(nr) - 1

ReDim Preserve sourceFilesErr(iSF, j + 1)

End If

lbFi = False

End If

ElseIf lbFo Then

If s = cE Or s = cF Or retryCopy = 0 Then

j = UBound(sourceFolderErr, 2)

For i = 0 To j

If sourceFolderErr(nr, i) = sf Then

lbFo = False

Exit For

End If

Next

If lbFo Then

sourceFolderErr(nr, j) = sf

copyCount(nr) = copyCount(nr) - 1

ReDim Preserve sourceFolderErr(iSF, j + 1)

End If

lbFo = False

End If

ElseIf ldFi Then

If s = cE Or s = cF Or retryCopy = 0 Then

j = UBound(destinationFileErr, 2)

For i = 0 To j

If destinationFileErr(nr, i) = sf Then

ldFi = False

Exit For

End If

Next

If ldFi Then

destinationFileErr(nr, j) = sf

copyCount(nr) = copyCount(nr) - 1

ReDim Preserve destinationFileErr(iSF, j + 1)

End If

ldFi = False

End If

ElseIf vz Then

If s = cE Or s = cF Or retryCopy = 0 Then

j = UBound(destinationSpaceErr, 2)

For i = 0 To j

If destinationSpaceErr(iSF, i) = sf Then

vz = False

Exit For

End If

Next

If vz Then

destinationSpaceErr(nr, j) = sf

            'copyCount(nr) = copyCount(nr) - 1

ReDim Preserve destinationSpaceErr(iSF, j + 1)

End If

vz = False

End If

ElseIf ddFi Then

j = UBound(deleteDestinationFilesErr, 2)

For i = 0 To j

If delDestinationFileErr(nr, i) = sf Then              

ddFi = False

Exit For

End If

Next

If ddFi Then

delDestinationFileErr(nr, j) = sf

delCount(nr) = delCount(nr) - 1

ReDim Preserve delDestinationFileErr(iSF, j + 1)

End If

ddFi = False

End If

s1 = s

Loop

End If

j = 0

k = UBound(sourceFilesErr, 2)

For i = 0 To k

If sourceFilesErr(nr, i) <> vbnullstring Then

j = 1

Exit For

End If

Next

If j = 1 Then

If vssProg <> vbnullstring Then

If checkVSSProg() Then

hc = getLockedCopyProg()

If hc <> vbnullstring Then

If Not IsArray(userGroupList) Then checkUserIsAdmin

If Not userGroupList(0) Then

vssError = vssError + 1

If vssError = 1 Then userHint "vssErr", "noAdmin"

Else

j = 0

For i = 0 To iSF -1

If sourceFilesErr(nr, i) <> vbnullstring Then j = j + 1

Next

userHint "vssCopyStart", j

l = UBound(sourceFilesErr, 2) - 1

For i = 0 To l

s = sourceFilesErr(nr, i)

If s <> vbnullstring Then

sf = oem2ansiTxt(s)

k = InStrRev(sf, cBSlash, -1, vbTextCompare)

so = Left(sf, k - 1)

sf = Right(sf, Len(sf) - k)

j =  InStrRev(so, sSS(1), -1, vbTextCompare) + Len(sSS(1))

sd = wrap(destination & Iif(sDateFolder = vbnullstring, vbnullstring, cbslash & sDateFolder) & _

Iif(separateDrive, sSS(0), vbnullstring)& sSS(1) & Right(so, Len(so) - j + 1))

If l > 2 Then userHint "vssCopy", sf

If vssProg = "HoboCopy" Then

so = wrap(so)

sf = wrap(sf)

s = hc & " /skipdenied /y " & so & cSpace & sd & cSpace & sf 'Quellpfad Zielpfad Dateityp

j = oWsh.run(s , 2, True)

If j <> 0 Then

vssError = vssError + 1

If vssError = 1 Then userHint "vssErr", "noAdmin"

Exit For

Else

sourceFilesErr(nr, i) = vbnullstring

copyCount(nr) = copyCount(nr) + 1

End If

Else '"ShadowCopy"

jw = 1000

Set f = oFS.GetFile(sf)

jw = f.Size / 12000 + 1000 'Wartezeit für Shadowkopy für Schließen

Set f = Nothing

sf = so & cbslash & sf

sf = wrap(sf)

s = hc & cSpace & sf & cSpace & sd & " /y /i /r" 'Quelldatei-pfad Zielpfad

oWsh.run s , 2

WScript.sleep 1000

f = oWsh.AppActivate("Warning")

If f Then

                    ' Wenn "Warning" als Dialogbox angezeigt wird konnte der VSS nicht initialisiert werden.

oWsh.sendkeys "~"

WScript.sleep 500

oWsh.sendkeys "%e"

vssError = vssError + 1

userHint "vssErr", "noAdmin"

Exit For

Else

WScript.sleep jw

k = 0

Do

WScript.sleep 1000

k = k + 1

                      ' "Information" ist das 5 Sek. Countdown-Fenster

f = oWsh.AppActivate("Information")

Loop Until f = True Or k = 120 '2 Minuten für die Sicherung

If f Then  oWsh.sendkeys "~"

If k < 120 Then

copyCount(nr) = copyCount(nr) + 1

sourceFilesErr(nr, i) = vbnullstring

End If

End If

End If

End If

Next

End If

End If

Else

closeAppsErr = closeAppsErr + 1

End If

Else

closeAppsErr = closeAppsErr + 1

End If

End If

End Function

' 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)) _

& cUL & addLeadingZero(Hour(jetzt)) _

& "~" & addLeadingZero(Minute(jetzt))

End Function

Function folderRotate()

Dim s, s2, rs, desFolder, i, j, k  

Set desFolder = oFS.GetFolder(destination)

i = 0

j = stages

If deleteBefore Then j = j - 1  

Set rs = folderRecordSet(desFolder)

If Not (rs.EOF) Then

rs.Sort = "date DESC"

rs.MoveFirst

Do Until rs.EOF

If i >= j Then

userHint "fr", vbnullstring

s = rs.Fields("name")

On Error Resume Next

oFS.deletefolder(s)

If Err.Number > 0 Then

Err.Clear

If oFS.folderexists(s) Then

forceDelete s

End If

End If

On Error Goto 0

WScript.sleep 100

End If

i = i + 1

rs.MoveNext

Loop

Else

End If

End Function

Function addLeadingZero(number)

If number < 10 Then number = "0" & number

addLeadingZero = number

End Function

' 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 = folderRecordSet(destinationFolder)

If Not (rs.EOF) Then

rs.Sort = "date DESC"    ' absteigend nach Erstellungszeitpunkt sortieren

rs.MoveFirst

Set getRecentFolder = oFS.GetFolder(rs.Fields("name"))

Else

Set getRecentFolder = Nothing

End If

rs.Close

Set rs = Nothing

End Function

Function getFolderObject(path)

If (oFS.FolderExists(path)) Then

Set getFolderObject = oFS.GetFolder(path)

Else

On Error Resume Next

Set getFolderObject = oFS.CreateFolder(path)

End If

End Function

Function folderRecordSet(oFolder)

Dim SubFolder, rsFieldNames

  ' Konstanten für ADO

Const adVarChar = 200

Const adDate = 7

rsFieldNames = Array("name", "date")

Set folderRecordSet = CreateObject("ADODB.RecordSet")

With folderRecordSet

.Fields.Append "name", adVarChar, 255

.Fields.Append "date", adDate

.Open

For Each SubFolder In oFolder.SubFolders

If Left(SubFolder.Name, 2) = "20" And Len(SubFolder.Name) = 16 Then ' nur die Datums-Ordner welche mit 20(00-02-10~15-20) beginnen in die Liste aufnehmen

.addnew rsFieldNames, Array(SubFolder.path, SubFolder.DateCreated)

End If

Next

End With

End Function

Function getFilePath(progPath, cR)

Dim i, wshEnv

i = 0

  'c:\Programme\Windows Resource Kits\Tools\robocopy.exe

progPath = oWsh.ExpandEnvironmentStrings("%ProgramFiles%") & "\Windows Resource Kits\Tools\" & cR 'c:\Programme\Windows Resource Kits\Tools\

If Not oFS.FileExists(progPath) Then

progPath = oWsh.ExpandEnvironmentStrings("%SystemDrive%") & cBSlash & cR 'c:\

If Not oFS.FileExists(progPath) Then

progPath = oWsh.ExpandEnvironmentStrings("%SystemRoot%") & "\system32\" & cR 'c:\Windows\system32

If Not oFS.FileExists(progPath) Then

progPath = sSP & cR 'Scriptpfad

If Not oFS.FileExists(progPath) Then

userHint "progErr", cR  'Programm wurde nicht gefunden

End If

Else

i = 1

End If

End If

Else

i = 2

End If

If i = 2 Then

    'Bei der Installation des Windows Resource Kits wird der Pfad in Path eingetragen

Set wshEnv = oWsh.Environment("process")

s = wshEnv("PATH")

If InStr(1, s, "Windows Resource Kits") Then

progPath = cR

Else

progPath = wrap(progPath)

End If

ElseIf i = 1 Then

    ' Programm liegt im System32-Ordner also auch über Path erreichbar

progPath = cR

Else

progPath = wrap(progPath)

End If

End Function

Function getLockedCopyProg()

Dim s

s = sSP & vssProg & ".exe" 'Scriptpfad

If Not oFS.FileExists(s) Then

s = sSP & vssProg & cBSlash & vssProg & ".exe" '\Scriptpfad\unterordner

If Not oFS.FileExists(s) Then

s = oWsh.ExpandEnvironmentStrings("%ProgramFiles%") & cBSlash & vssProg & cBSlash & vssProg & ".exe"

If Not oFS.FileExists(s) Then ' Speziell für Shadowcopy

s = oWsh.ExpandEnvironmentStrings("%ProgramFiles%") & "\Runtime Software\ShadowCopy\" & vssProg & ".exe" 'c:\Programme

If Not oFS.FileExists(s)Then

userHint "vssErr", vssProg  'Prog wurde nicht gefunden

s = vbnullstring

End If

End If

End If

End If

getLockedCopyProg = wrap(s)

End Function

Function wrap(v)

Dim va, s

va = v

If IsArray(va) Then

For i = 0 To UBound(va)

s = Replace(va(i), cSlash, cBSlash)

If InStr(1, s, cSpace) Then

va(i) = cDQ & s & cDQ

Else

va(i) = s

End If

Next

ElseIf va <> vbNullString Then

va = Replace(va, cSlash, cBSlash)

If InStr(1, va, cSpace) Then va = cDQ & va & cDQ

End If

wrap = va

End Function

'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

Function decover(s)

s = Trim(s)

If Left(s, 1) = cDQ And Right(s, 1) = cDQ Then

decover = Mid(s, 2, Len(s) - 2)

Else

decover = s

End If

End Function


Function Iif(v, vTrue, vFalse)

If v Then

IIf = vTrue

Else

IIf = vFalse

End If

End Function

Function openArgs()

Dim oArgs, sOA, s, s2, n, x

Set oArgs = WScript.Arguments

If oArgs.Count = 0 Then

    'Abfangen wenn kein Argument übergeben wurde

Else

For i = 0 To oArgs.Count - 1

On Error Resume Next

sOA = oArgs(i)

s2 = Replace(UCase(Left(sOA, 3)), "/", "-")

On Error Goto 0

Select Case s2

Case "-HE", "-H", "-?", "-", "-HILFE" : help  = "?"

Case Else                             : roboCopyIni = decover(sOA)

End Select

Next

End If

End Function

' Sollten das Scropt mit einer ini-Datei gestartet werden
' Wenn kein ini-Dateipfad übergeben wird so wird versicht eine ini-Datei mit dem ScriptNamen aufzurufen.
Function readIniFile()

Dim f, keyValue, key, valu, i, j

On Error Resume Next

i = checkPath(roboCopyIni)

If i >= 2 Then

    'ist schon ein absoluter Pfad

If InStr(1, roboCopyIni, "ini") = 0 Then roboCopyIni = Replace(WScript.Name, "vbs", "ini")

ElseIf i = 0 Then

roboCopyIni = sSP & Replace(WScript.ScriptName, "vbs", "ini")

ElseIf i = -1 Then

roboCopyIni = sSP & roboCopyIni

End If

Set f = oFS.OpenTextFile(roboCopyIni, 1, False)

If Err.Number <> 0 Then

Err.Clear

roboCopyIni = vbnullstring

Else

    'userHint "readIni", vbnullstring

Do Until f.AtEndOfStream

s = f.Readline

keyValue = Split(s, "=")

If UBound(keyValue) > 0 Then

valu = decover(keyValue(1))

keyValue(0) = Trim(keyValue(0))

Select Case keyValue(0)

Case "arraySplitter"      : arraySplitter      = Iif(valu = vbnullstring, ";", valu)

Case "PWCrypt"            : PWCrypt            = Iif(valu = vbnullstring, False, CBool(valu))

Case "sourceFolders"      : sourceFolders      = arrayTrim(valu)

Case "destination"        : destination        = valu

Case "volumeNameSerialNr" : volumeNameSerialNr = arrayTrim(valu)

Case "rotationDays"       : rotationDays       = CInt(Iif(valu = vbnullstring, 0, valu))

Case "excludeFiles"       : excludeFiles       = arrayTrim(valu)

Case "excludeFolder"      : excludeFolder      = arrayTrim(valu)

Case "includeFileType"    : includeFileType    = arrayTrim(valu)

Case "touchedFiles"       : touchedFiles       = arrayTrim(valu)

Case "separateDrive"      : separateDrive      = Iif(valu = vbnullstring, False, CBool(valu))

Case "stages"             : stages             = CInt(valu)

Case "deleteBefore"       : deleteBefore       = Iif(valu = vbnullstring, False, CBool(valu))

Case "mirror"             : mirror             = Iif(valu = vbnullstring, False, CBool(valu))

Case "mirrorStore"        : mirrorStore        = valu

Case "copyFileFlags"

If valu = vbnullstring Then

copyFileFlags = False

Else

copyFileFlags = CBool(valu)

End If

Case "minFileSize"        : minFileSize        = valu

Case "maxFileSize"        : maxFileSize        = valu

Case "bandWidth"          : bandWidth          = valu

Case "skipJunctions"      : skipJunctions      = valu

Case "showShell"          :

showShell          = Iif(valu = vbnullstring, False, CBool(valu))

Case "hintTime"           : hintTime           = CInt(Iif(valu = vbnullstring, 20, valu))

Case "closeApps"          : closeApps          = arrayTrim(valu)

Case "extendedDelete"     : extendedDelete     = valu' Iif(valu = vbnullstring, False, CBool(valu))

Case "retryCopy"          : retryCopy          = valu

Case "waitRetry"          : waitRetry          = valu

Case "hlnk"               : hlnk               = CInt(Iif(valu = vbnullstring, 0, valu))

Case "logging"            : logging            = CInt(Iif(valu = vbnullstring, 0, valu))

Case "logFile"            : logFile            = valu

Case "userhintFile"       : userhintFile       = valu

Case "tcVolume"           : tcVolume           = valu

Case "tcKeyfile"          : tcKeyfile          = valu

Case "tcPassword"         : tcPassword         = iif(PWCrypt, Crypt(valu, False), valu)

If PWCrypt Then

tcPassword = Crypt(valu, False)

Else

tcPassword = valu

End If

Case "tcSoftmount"        : tcSoftmount        = arrayTrim(valu)

Case "tcShortcut"         : tcShortcut         = valu

Case "vssProg"            : vssProg            = valu

Case "emailInfo"          : emailInfo           = CInt(Iif(valu = vbnullstring, 0, valu))

Case "emailSubject"       : emailSubject        = Iif(valu = vbnullstring, "RoboCopy Bericht", valu)

Case "emailFrom"          : emailFrom           = valu

Case "emailReceiver"      : emailReceiver       = valu

Case "emailUser"          : emailUser           = valu

Case "emailPassword"

If PWCrypt Then

emailPassword = Crypt(valu, False)

Else

emailPassword = valu

End If

Case "smtpServer"         : smtpServer          = valu

Case "scriptErr"          : scriptErr           = CBool(valu)

'          Case ""  : = valu

Case Else

End Select

End If

Loop

f.close

End If

End Function

Function arrayTrim(valu)

Dim s

If valu = vbnullstring Then

s = Array("")

Else

s = Split(valu, arraySplitter)

For i = 0 To UBound(s)

s(i) = Trim(s(i))

Next

End If

arrayTrim = s

End Function

Function scriptParameter()

Dim i

minFileSize = CInt(Iif(minFileSize = vbnullstring, 0, minFileSize))

maxFileSize = CInt(Iif(maxFileSize = vbnullstring, 0, maxFileSize))

bandWidth = CInt(Iif(bandWidth = vbnullstring, 0, bandWidth))

skipJunctions = Iif(skipJunctions = vbnullstring, True, CBool(skipJunctions))

retryCopy = CInt(Iif(retryCopy = vbnullstring, 0, retryCopy))

waitRetry = CInt(Iif(retryCopy = vbnullstring, 0, retryCopy))

If hlnk = vbnullstring Then hlnk = 0

If logging = vbnullstring Then logging = 0

If stages = vbnullstring Or stages = "0" Then  stages = 1

If stages = 1 Then

sDateFolder = vbnullstring

Else

sDateFolder = cBSlash & getDateFolderName()

End If

vssError = 0

sInfo = vbnullstring

fInfo = 0

scriptErrTxt = vbnullstring

fNetworkLW = False

mirrorSaved = 0

iSF = UBound(sourceFolders)

ReDim sourceFilesErr(iSF, 0)

ReDim sourceFolderErr(iSF, 0)

ReDim destinationFileErr(iSF, 0)

ReDim delDestinationFileErr(iSF, 0)

ReDim destinationSpaceErr(iSF, 0)

ReDim copyCount(iSF)

ReDim delCount(iSF)

ReDim sourceSubfolder(iSF)

i = UBound(closeApps)

ReDim startApps(i)  

spaceErrCount = 0

arrReg(cSDate)              = "DAT"

arrReg(cVolumeName)         = "VN"

arrReg(cVolumeSerialNumber) = "VSN"

arrReg(cMediaType)          = "MT"

arrReg(cDriveType)          = "DT"

arrReg(cFileSystem)         = "FS"

arrReg(cServer)             = "SVR"

destination = Replace(destination, cSlash, cBslash)

If Right(destination, 1) = cBslash Then destination = Left(destination, Len(destination) - 1)

For i = 0 To iSF

sourceFolders(i) = Replace(sourceFolders(i), cSlash, cBslash)

If Right(sourceFolders(i), 1) = cBslash Then

sourceFolders(i) = Left(sourceFolders(i), Len(sourceFolders(i)) - 1)

sourceSubfolder(i) = False

Else

sourceSubfolder(i) = True

End If

copyCount(i) = 0 ' setzen

delCount(i)  = 0

Next

End Function

' Wenn mehr als eine Version der Dateien gesicht werden soll dann werden hier
' einstellen wie die Hardlinks erzeugt werden sollen.
' Wenn nur eine Version gesichert werden soll dann ist auch kein Hardlink-Progamm nötig
Function setHardlink()

If stages = 1 Then hlnk = 0

If hlnk = 1 Then

If Not IsArray(userGroupList) Then checkUserIsAdmin()

If Not userGroupList(0) Then

hlnk = 0

userHint "fsutilErr", vbnullstring

End If

ElseIf hlnk = 2 Then

getFilePath phl, "ln.exe"

    'phl = phl & iif(showShell, vbnullstring, " --quiet ") & " --recursive "    

j = UBound(excludeFiles) - 1

For i = 0 To j

phl = phl & " -x " & wrap(excludeFiles(i)) & cSpace

Next

j = UBound(excludeFolder) - 1    

For i = 0 To j

phl = phl & " -X " & wrap(excludeFolder(i)) & cSpace      

Next

phl = phl & iif(showShell, vbnullstring, " -q ") & " -r "

Else

hlnk = 0 'falls etwas falsches eingetragen wurde

End If

End Function

Function regReadRC()

Dim i, j

On Error Resume Next

j = UBound(arrReg)

For i = 0 To j

arrReg(i) = oWsh.RegRead(cReg & arrReg(i))

Next

On Error Goto 0

End Function

Function regWriteRC()

Dim s, dd

On Error Resume Next

If IsEmpty(oWmi) Or IsNull(oWmi) Then

    '\\Server-Pfad also kein Wechseldatenträger

oWsh.RegWrite cReg & "SVR", wmiP(cServer), cSZ

Else

With oWsh

If wmiP(cVolumeName) <> arrReg(cVolumeName) Or wmiP(cVolumeSerialNumber) <> arrReg(cVolumeSerialNumber) Then

.RegWrite cReg & "DAT", CLng(date()), cSZ

.RegWrite cReg & "VN",wmiP(cVolumeName) , cSZ

.RegWrite cReg & "VSN",wmiP(cVolumeSerialNumber) , cSZ

.RegWrite cReg & "MT", wmiP(cMediaType), cSZ

.RegWrite cReg & "DT", wmiP(cDriveType), cSZ

.RegWrite cReg & "FS", wmiP(cFileSystem), cSZ

.RegWrite cReg & "SVR", wmiP(cServer), cSZ

If rotationDays = 0 Then

s = vbnullstring      

Else

s = "Datenträger wurde getauscht"      

End If

.RegWrite cReg & "NFO", s, cS

.RegWrite cReg & "DD", CLng(date()) & cK & rotationDays, cSZ  

Else

If wmiP(cServer) <> arrReg(cServer) Then .RegWrite cReg & "SVR", wmiP(cServer), cSZ

If rotationDays = 0 Then

s = vbnullstring      

.RegWrite cReg & "NFO", s, cSZ            

.RegWrite cReg & "DD", s, cSZ            

Else

i = 0

i = arrReg(cSDate)

dd = CLng(date()) - i

.RegWrite cReg & "DD", dd & cK & rotationDays, cSZ

If dd > rotationDays Then

s = "Wechsel-Datenträger tausch seit " & dd - rotationDays & " Tag(en) fällig !"

If fInfo < 3 Then

fInfo = 2

emailSubject = emailSubject & cSpace & s

End If

.RegWrite cReg & "NFO", s, cSZ

ElseIf dd = rotationDays Then

s = "Wechsel-Datenträger tauschen !"

If fInfo < 3 Then

fInfo = 2

emailSubject = emailSubject & cSpace & s

End If

.RegWrite cReg & "NFO", s, cSZ

Else

s = "Wechsel-Datenträger tauschen In "  & rotationDays - dd & " Tag(en)"

.RegWrite cReg & "NFO", s, cSZ

End If

End If

End If

rotationHint = s

End With

End If

On Error Goto 0

End Function

Function closeAppication()

Dim obj, objc, system, process, s, i

  'Sanftes Schließen der Anwendung hier z.B. Outlook

closeAppication = False

If closeApps(0) = vbnullstring Then Exit Function

On Error Resume Next

For i = 0 To UBound(closeApps)

Set obj = Nothing

s = closeApps(i)

Select Case LCase(s)

Case "outlook"

Set obj = GetObject(, "Outlook.Application") '"Outlook.Application.12"

If Not obj Is Nothing Then

obj.quit

closeAppication = True

startApps(i)  = True

userHint "closeApp", s

End If

Case "winword"

Set obj = GetObject(, "Word.Application")

If Not obj Is Nothing Then

For Each objc In obj.Documents

With objc

If Not objc.Saved Then

If objc.ReadOnly Then

i = InStrRev(objc.FullName, cD, -1, vbTextCompare) 'Punkt der Appendix-Trennung

s = Left(objc.FullName, i - 1) & "_Rsync." & Right(objc.FullName, Len(objc.FullName) - i)

.SaveAs s

Else

If .FullName = .Name Then 'Noch nicht gesichert

If .Characters.Count < 2 Then

.close

Else

s = GetDate & .Name

.saveas s

End If

Else

.Save

End If

End If

End If

Close

End With

Next

obj.Quit

closeAppication = True

startApps(i) = True

userHint "closeApp", s

End If

Case "excel"

Set obj = GetObject(, "Excel.Application")

If Not obj Is Nothing Then

For Each objc In obj.Workbooks

With objc

If Not objc.Saved Then

If objc.ReadOnly Then

i = InStrRev(objc.FullName, cD, -1, vbTextCompare) 'Punkt der Appendix-Trennung

s = Left(objc.FullName, i - 1) & "_Rsync." & Right(objc.FullName, Len(objc.FullName) - i)

.SaveAs s

Else

If .FullName = .Name Then 'Noch nicht gesichert

s = GetDate & .Name

.saveas s

Else

.Save

End If

End If

End If

.Close

End With

Next

obj.Quit

closeAppication = True

startApps(i) = True

userHint "closeApp", s

End If

Case "powerpoint"

Set obj = GetObject(, "PowerPoint.Application")

If Not obj Is Nothing Then

For Each objc In obj.Presentations

With objc

If Not .Saved Then

If .ReadOnly Then

i = InStrRev(.FullName, cD, -1, vbTextCompare) 'Punkt der Appendix-Trennung

s = Left(.FullName, i - 1) & "_Rsync." & Right(.FullName, Len(.FullName) - i)

.SaveAs s

Else

If .FullName = .Name Then 'Noch nicht gesichert

s = GetDate & .Name

.saveas s

Else

.Save

End If

End If

End If

.Close

End With

Next

obj.Quit

closeAppication = True

startApps(i) = True

userHint "closeApp", s

End If

Case Else

End Select

If closeAppication Then WScript.Sleep 2000

Next

For i = 0 To UBound(closeApps)

    'Sollte das "sanfte" Schließen nicht funktionieren dann die Anwendung abschießen wenn GRO? geschrieben

If StrComp("OUTLOOK", closeApps(i), vbBinaryCompare) = 0 Then

s = "outlook.exe"

ElseIf StrComp("WINWORD", closeApps(i), vbBinaryCompare) = 0 Then

s = "winword.exe"

ElseIf StrComp("EXCEL", closeApps(i), vbBinaryCompare) = 0 Then

s = "excel.exe"

ElseIf StrComp("POWERPOINT", closeApps(i), vbBinaryCompare) = 0 Then

s = "powerpoint.exe"

ElseIf Right(closeApps(i), 4) = ".exe" Then

s = LCase(closeApps(i))

Else

s = vbnullstring

End If

If s <> vbnullstring Then

Set obj = GetObject("winmgmts:")

Set system = obj.instancesOf("win32_process")

For Each process In system

If LCase(process.name) = s Then

process.Terminate (0)'Programm-Name klein schreiben

closeAppication = True

startApps(i) = True

WScript.Sleep 2000

End If

Next

Set obj = Nothing

Set system = Nothing

End If

Next

End Function


Function startProgs()

Dim s, i, j

j = UBound(startApps)

For i = 0 To j

If startApps(i) = True Then

s = wrap(closeApps(i))

i = oWsh.Run(s, 6)

WScript.sleep 150

End If

Next

End Function

' Diese Funktion auskommentieren wenn der LW-Buchstabe als Unterordner verwendet werden soll
' auch wenn alle zu sichernden Pfade auf den selben LW liegen
Function checkSeparateSourceDrive()

If separateDrive = False Then

ElseIf UBound(sourceFolders) < 1 Then

  '  separateDrive = False

Else

s = Left(sourceFolders(0), 1)

For i = 1 To UBound(sourceFolders)

v = Left(sourceFolders(i), 1)

If v <> s Then

Exit Function

End If

Next

End If

separateDrive = False

End Function

Function checkPath(path)

Dim i, j

If path = vbnullstring Then

checkPath = 0

ElseIf Left(path,2)= c2BSlash Then

checkPath = 2 'LAN

Else

i = asc(UCase(Left(path, 1)))

j = InStr(1, path, cBSlash)

If i >= 65 And i<= 90 And (j = 0 Or j = 3) Then 'M: oder M:\xyz

checkPath = 3 'LW

'    ElseIf i = 63 And (j = 0 Or j = 3) then '

ElseIf i = 63 And j = 3 Then '

checkPath = 1 '?:\xyz

ElseIf i = 63 And j = 0 Then '

checkPath = 0.5 '?:\    

Else

checkPath = -1 'Falsch

End If

End If

End Function

'Pfad für die Anzeige kürzen
Function slash_folder(sFolder, maxlen, sStartChr, sEndChr)

On Error Resume Next

Dim j, l, k

If maxlen = vbNullString Or maxlen = 0 Then maxlen = 70 'Die voreingestelle Breite der CMD-Shell ist 80 Zeichen

If Len(sFolder) > maxlen Then

j = InStr(maxlen * 0.3, sFolder, cBSlash)

If j = 0 Then

slash_folder = sStartChr & Left(sFolder, maxlen * 0.3) & "...\..." & Right(sFolder, Len(sFolder) - (maxlen * 0.7) + 1) & sEndChr

Else

k = InStrRev(sFolder, cBSlash, -1, vbTextCompare)

l = InStrRev(Left(sFolder, k - 1), cBSlash, -1, vbTextCompare)

If l = j Or l = 0 Then l = k

slash_folder = sStartChr & Left(sFolder, j) & "..." & Right(sFolder, Len(sFolder) - l + 1) & sEndChr

End If

ElseIf sFolder = vbNullString Then

slash_folder = vbNullString

Else

slash_folder = sStartChr & sFolder & sEndChr

End If

On Error Goto 0

End Function

Function userHint(sh, k)

Dim s, t, ok, i, s2, s3

t = 5: ok = vbOKOnly

Select Case sh

Case "closeApp"

s = "-> """ & k & """ wurde geschlossen."

Case "CreateHardlink"

s = String(5, cSpace) & "Hardlink Kopie der alten Sicherung erstellen"

Case "delToUpdate"

s = String(5, cSpace) & "Geänderte Dateien im Sicherungs-Ordner löschen"

Case "dryRun"

s = String(4, cSpace) & slash_folder(sourceFolders(k), 0, vbNullString, vbnullstring) 'vbcrlf

Case "email"

If k = True Then

s = "E-Mail-Bericht wurde versendet"

emailErr = s

s = "-> " & s

Else

emailErr = "E-Mail Sendefehler: " & emailErr

s = "-! " & emailErr

End If

Case "hlnkErr"

s = "Voll-Backup! FileSystem ist " & k

infoHint = infoHint & cAS & s & vbcrlf

s = "-! " & s

Case "fsutilErr"

s =  " Voll-Backup! FSUTIL benötigt Admin-Rechte"

infoHint = infoHint & cAS & s & vbcrlf

s = "-! " & s

Case "logErr"

s =  "Log-Datei konnte nicht angelegt werden"      

infoHint = infoHint & cAS & s & vbcrlf

s = "-! " & s

logging = 0

Case "init"

s = vbcrlf & "---- RoboCopy Sicherung Start Ver." & cVersion & " ----" & vbcrlf

Case "lwNameChange"

s = "Backup -LW via Volume-ID geändert -> " & destination

infoHint = infoHint & cAS & s & vbcrlf

      'Exit Function

s = "-! " & s

Case "lf"

s = "-> Log-Datei (" & iif(logging = 3, "unbegrenzt", "Stages: " & stages) & ") " &  slash_folder(logFile, 55, vbNullString, vbnullstring)

Case "skip"

s = String(5, cSpace) &  "Überspringen da keine Änderung"

Case "startDryRun"

s = "-> Änderungen Quelle -> Ziel ermitteln"

Case "startRoboRun"

s = "-> Sicherung durchführen"

Case "RoboRun"

s = String(4, cSpace) & slash_folder(sourceFolders(k), 0, vbNullString, vbnullstring)

'    Case "ftp"
'      s = "FTP-Upload starten"

Case "fr"

s = "-> Ältesten Sicherungsordner löschen."

Case "progErr"

s = "Progamm " & cDQ & Replace(k, ".exe", vbnullstring) & cDQ & " wurde nicht gefunden"

t = hintTime: ok = vbOKOnly + vbCritical

WScript.echo "-| " & s

If showShell Then oWsh.popup s, t, cRS, ok

userHint "End", "quit"

Case "iniErr"

s = cDQ & "Robocopy.ini" & cDQ & " wurde nicht gefunden"

t = hintTime: ok = vbOKOnly + vbCritical

WScript.echo "-| " & s

userHint "End", "quit"

Case "kopie"

s = String(5, cSpace) & "Sicherung durchführen"

Case "start"

s = vbcrlf & "-> Folgende Quellen sichern:" & vbcrlf '& String(4, cSpace) & _

j = UBound(sourceFolders)

For i = 0 To j

s2 = sourceFolders(i)

If Not Left(sourceFolders(i), 1) = "-" Then

s = s & String(4, cSpace) & slash_folder(sourceFolders(i), 0 , vbNullString, vbcrlf)

End If

Next

      'Join(sourceFolders, vbcrlf & String(4, cSpace)) & vbcrlf & _
      s = s & "-> Nach: " & slash_folder(destination, 0, vbNullString, vbnullstring) & vbcrlf

Case "no_kopie"

s = String(5, cSpace) & "Keine Veränderungen"

    'Case "readIni"
    '  s = "-> RoboCopy.ini Datei auslesen"

Case "source"

s = k

Case "nochange"

s = "-> Keine Änderung der Quelldaten."

Case "tcMount"

s = "-> TrueCrypt-Container einbinden ..."

Case "update"

s =  String(5, cSpace) & "Daten haben sich geändert"

Case "vssCopyStart"

s = "-> Sicherung von " & k & " gesperrten Datei(en) durch " & vssProg '& " Sicherung von: " & k

Case "vssCopy"

s = "   " & k

Case "vssErr"

Select Case k

Case "shadowcopy", "robocopy"

s = k & "' nicht gefunden"

Case "noAdmin"

s = "VSS Schattenkopie nicht möglich da '" & oWsh.ExpandEnvironmentStrings("%USERNAME%") & "' kein Admin"

Case Else

s = "VSS Schattenkopie nicht möglich da falscher Eintrag -> " & k

End Select

vssErr = s

s = "-! " & s

Case "tcmounted"

s = "-> Truecrypt-LW eingebunden nach " & UCase(lw) & ":"

Case "ErrMSG"

s = "-? Systemfehlermeldung (Funktion) : " & k

Case "destErr"

Select Case k

Case "TCN"

s = "TrueCrypt-Container muss auf ein LW gemountet werden." & vbcrlf & _

"Backup-Verzeichnis ist ein Netzwerkpfad." &  vbcrlf & destination

Case "LS"

s = "Nicht genügEnd Speicherplatz auf den Backup-LW ! " & Left(destination, 2)

Case "LW"

s = "Backup-Laufwerk " & Left(destination, 2) & " ist nicht vorhanden." & vbcrlf & _

"Sicherungsmedium angeschlossen ?"

Case "NWP"

s = "Backup-Netzwerkpfad """ & destination & """ nicht erreichbar"

Case "SRV"

s = "Nur Server angegeben ohne Unter-Ordner """ & destination & """"

'        Case "TCME"
'             s = "TrueCrypt-Container konnte nicht auf ein LW gemountet werden."

Case "LW_P"

s = "Backup-Ordner """ & destination & """ ist nicht vorhanden und kann auch nicht angelegt werden"

Case "DVD"

s = "Backup-Ordner  """ & destination & """ liegt auf ein DVD-Laufwerk"

Case "WERR"

s = "Keine Schreibrechte im Sicherungspfad." & vbcrlf & destination

If tcVolume <> vbnullstring Then dismountTrueCrypt()

Case "USB"

s = "Backup-Ordner """ & destination & """ ist nicht beschreibbares USB-Medium"

Case "ZLW"

s = "Backup-Ordner """ & destination & """ ist gleich einem Quell-Ordner"

Case "OZLW"

s = "Backup-Ordner """ & destination & """ nicht korrekt"

Case Else

s = k

End Select

logging = 0

change = -1

destinationErr = s

If emailInfo > 0 Then

logFile = sLog & "_rep" & cAppLog

s = "Sicherung nicht möglich !"

emailSubject = emailSubject & s

End If

WScript.echo "-| " & destinationErr

userInfo()

If showShell Then

t = hintTime: ok = vbOKOnly + vbCritical

oWsh.popup destinationErr, t, cRS & " >> Abbruch <<", ok

End If

userHint "End", "quit"

Case "srcErr"

logging = 0

change = -1

s = "Kein Sicherungs-Ordner ist korrekt."

If emailInfo > 0 Then

logFile = sLog & "_rep" & cAppLog

emailSubject = emailSubject & " - " & s

End If

userInfo()

WScript.echo "-| " & s

If showShell Then

t = hintTime: ok = vbOKOnly + vbCritical

oWsh.popup s, t, cRS & " >> Abbruch <<", ok

End If

userHint "End", "quit"

Case "tcErr"

Select Case k

Case "tcProg": s = "TrueCrypt-Programm wurde nicht gefunden."

Case "noWritePermission"

s = "Benutzer '" & oWsh.ExpandEnvironmentStrings("%USERNAME%") & "' hat keine Schreibrechte " & vbcrlf & "auf TrueCrypt-Container " & tcVolume

Case "mountErr": s = "TrueCrypt-Container konnte NICHT gemountet werden. (Passwort korrekt, Schreibrechte?)"

Case "NoKeyFile": s = "TrueCrypt-Schlüsseldatei """  & tcKeyfile & """ nicht vorhanden"

Case "noVolume": s = "kein(e) TrueCrypt-Volume/-Datei angegeben"

Case "same"

s = "Laufwerks-Buchstabe '" & lw & "' auf den gemountet werden soll ist gleich dem LW-Pfad des Containers. " & vbcrlf & _

String(3, cSpace) & "Da er klein angegeben wurde wird nicht nach einem freien LW-Buchstabe gesucht."

Case "wrongPath": s = "Pfad zur TrueCrypt Container-Datei korrigieren '" & tcVolume & "' "

Case "wrongPartition": s = "Partition '" & tcVolume & "' nicht gefunden"

End Select

tcErr = s

WScript.echo "-| " & s

logging = 0

change = -1

If emailInfo > 0 Then

logFile = sLog & "_rep" & cAppLog

emailSubject = emailSubject & " - TrueCrypt Fehler - Sicherung nicht möglich !"

End If

dismountTrueCrypt(True)

userInfo()

If showShell Then

t = hintTime: ok = vbOKOnly + vbCritical

oWsh.popup s, t, cRS & " >> Abbruch <<", ok

End If

userHint "End", "quit"

Case "End"

s = vbcrlf & "-> " & duration & vbcrlf & vbcrlf & "---- RoboCopy Sicherung Ende ----"

If showShell Then beeep(1)

End Select

If fCS Then WScript.echo s

If k = "quit" Then WScript.quit

End Function

Function userInfo()

checkErrFiles()

logFiles()

If showshell Or emailInfo > 0 Then sInfo = finalInfo()

If scriptErr Then scriptErrInfoMail()

scriptdauer(0)

sendEMail()

End Function

Function finalInfo()

Dim s, s2, s3, fLog

On Error Resume Next

For i = 0 To UBound(sourceFolders)

If Left(sourceFolders(i), 1) = "-" Then

s2 = Right(sourceFolders(i), Len(sourceFolders(i)) -1)

s3 = "Falscher Pfad ! "

Else

s2 = sourceFolders(i)

s3 = vbNullString

End If

s = s  & vbcrlf & i + 1 & ". Quelle: " & s3 & slash_folder(s2, 64, vbNullString, vbcrlf)

sTP = oWsh.ExpandEnvironmentStrings("%temp%") & cBSlash & cRC & cDR & i & cAppLog

Set oF = oFS.opentextfile(sTP)

If Err.Number = 0 Then

Do

s2 = Replace(LTrim(oF.readline), " :", ":")

If InStr(1, s2, "Files:") Or InStr(1, s2, "Dateien:") Then 'XP Or Vista, 7

s2 = Replace(s2, Chr(9), cSpace)

Do

s2 = Replace(s2, c2Space, cSpace)

Loop Until InStr(1, s2, c2Space) = 0

v = Split(s2, cSpace)

j = Len(v(1))

s2 = String(6 - j, cSpace)

j = Len(v(2))

s3 = String(6 - j, cSpace)

s = s & "Total : " & v(1) & s2 & chr(9) & "Kopiert : " & v(2) + copyCount(i) & s3 & chr(9) & "Gelöscht : " & CLng(v(6)) + delCount(i) & vbcrlf

End If

Loop Until oF.AtEndOfStream

Else

Err.Clear

End If

Next

oF.Close

Set oF = Nothing

s = s & "$" & vbcrlf

If vssErr <> vbnullstring Then s = s & cAS & vssErr & vbcrlf

s2 = get_lockedSourceFilesErr(0) & get_sourceFolderErr(0) & get_destinationFileErr(0) & get_delDestinationFileErr(0)

If destinationErr <> vbnullstring Then

s2 = s2 & cAS & destinationErr & vbcrlf

Else

s3 = get_destinationSpaceErr(0)

If spaceErrCount > 0 Then

s2 = s2 & cAS & spaceErrCount & " Dateien nicht gesichert da Backup-LW voll" & vbcrlf & s3

End If

End If

If s2 <> vbnullstring Then

s = s & s2

fInfo = 3

End If

If hlnk = 2 And Left(destination, 2) = c2BSlash Then

s = s & cAS & """Fsutil"" kann keine Hardlinks auf einem Netzwerk-LW erzeugen." & vbcrlf & "Es wurde eine Vollkopie erstellt." & vbcrlf

fInfo = 3

End If

If mirrorSaved > 0 Then

s = s & cAS & mirrorSaved & " gelöschte Datei(en) verschoben In den Ablage-Ordner" & vbcrlf

fInfo = 3

End If

If change = 0 Then  s = s & cAS & "Keine Änderung der Quelldaten." & vbcrlf

If infoHint <> vbnullstring Then s = s & infoHint

If tcErr <> vbnullstring Then

s = s & cAS & tcErr & vbcrlf

fInfo = 3

End If

If emailInfo > 0 Then  s = s & "|@|" ' Marker setzen da die Email noch nicht versendet wurde

  'If emailErr <> vbnullstring then s = s & cAS & emailErr & vbcrlf

If rotationHint <> vbnullstring Then s = s & cAS & rotationHint & vbcrlf

If logging > 0 Then s = s & cAs & "Log-Datei: " & slash_folder(logFile, 35, vbNullString, vbcrlf)

s = stages & " Version(en) Sicherung  - |#|" & vbcrlf & "$" & vbcrlf & "Ziel : " & slash_folder(destination, 0, vbNullString, vbcrlf) & "$" & s

finalInfo = s

End Function

Function get_lockedSourceFilesErr(fExtended)

Dim nr, j, s, s2, f

s = vbnullstring

f = False

j = UBound(sourceFilesErr, 2)

If j > 0 Then

For nr = 0 To iSF

If fExtended Then

For i = 0 To j - 1

s2 = sourceFilesErr(nr, i)

If s2 <> vbnullstring Then s = s & s2 & vbcrlf

Next

End If

If sourceFilesErr(nr, j) = True Then f = True

Next

If f Then s = cAS & "Gesperrte Datei(en) wurden nicht gesichert" & vbcrlf & s

End If

get_lockedSourceFilesErr = s

End Function

Function get_sourceFolderErr(fExtended)

Dim nr, j, s, s2, f

s = vbnullstring

f = False

j = UBound(sourceFolderErr, 2)

If j > 0 Then

For nr = 0 To iSF

If fExtended Then

For i = 0 To j - 1

s2 = sourceFolderErr(nr, i)

If s2 <> vbnullstring Then s = s & s2 & vbcrlf

Next

End If

If sourceFolderErr(nr, j) = True Then f = True

Next

If f Then s = cAS & "Zugriff auf Quell-Ordner(n) verwehrt" & vbcrlf & s

End If

get_sourceFolderErr = s

End Function

Function get_destinationFileErr(fExtended)

Dim nr, j, s, s2, f

s = vbnullstring

f = False

j = UBound(destinationFileErr, 2)

If j > 0 Then

For nr = 0 To iSF

If fExtended Then

For i = 0 To j - 1

s2 = destinationFileErr(nr, i)

If s2 <> vbnullstring Then s = s & s2 & vbcrlf

Next

End If

If destinationFileErr(nr, j) = True Then f = True

Next

If f Then s = cAS & "Zugriff auf Ziel-Dateien(n) verwehrt" & vbcrlf & s

End If

get_destinationFileErr = s

End Function

Function get_delDestinationFileErr(fExtended)

Dim nr, j, s, s2, f

s = vbnullstring

f = False

j = UBound(delDestinationFileErr, 2)

If j > 0 Then

For nr = 0 To iSF

If fExtended Then

For i = 0 To j - 1

s2 = delDestinationFileErr(nr, i)

If s2 <> vbnullstring Then s = s & s2 & vbcrlf

Next

End If

If delDestinationFileErr(nr, j) = True Then f = True

Next

If f Then s = cAS &"Entfernte Dateien im Backup löschen fehlgeschlagen da gesperrt." & vbcrlf & s

End If

get_delDestinationFileErr = s

End Function

Function get_destinationSpaceErr(fExtended)

Dim nr, j, s, s2', f

  'f = False

j = UBound(destinationSpaceErr, 2)

If j > 0 Then

For nr = 0 To iSF

If fExtended Then

For i = 0 To j - 1

s2 = destinationSpaceErr(nr, i)

If s2 <> vbnullstring Then

s = s & s2 & vbcrlf

spaceErrCount = spaceErrCount + 1

End If

Next

End If

      'If destinationSpaceErr(nr, j) = True then f = True

Next

    'If f then s = "Der Backup-Ordner ist voll" & s

End If

get_destinationSpaceErr = s

End Function

' in das letze Feld ja/nein-Info schreiben ob es Fehler mit den Dateien gab
Function checkErrFiles()

Dim nr, j

j = UBound(sourceFilesErr, 2)

For nr = 0 To iSF

sourceFilesErr(nr, j) = False

For i = 0 To j - 1

If sourceFilesErr(nr, i) <> vbnullstring Then

sourceFilesErr(nr, j) = True

Exit For

End If

Next

Next

j = UBound(sourceFolderErr, 2)

For nr = 0 To iSF

sourceFolderErr(nr, j) = False

For i = 0 To j - 1

If sourceFolderErr(nr, i) <> vbnullstring Then

sourceFolderErr(nr, j) = True

Exit For

End If

Next

Next

j = UBound(destinationFileErr, 2)

For nr = 0 To iSF

destinationFileErr(nr, j) = False

For i = 0 To j - 1

If destinationFileErr(nr, i) <> vbnullstring Then

destinationFileErr(nr, j) = True

Exit For

End If

Next

Next

j = UBound(delDestinationFileErr, 2)

For nr = 0 To iSF

delDestinationFileErr(nr, j) = False

For i = 0 To j - 1

If delDestinationFileErr(nr, i) <> vbnullstring Then

delDestinationFileErr(nr, j) = True

Exit For

End If

Next

Next

j = UBound(destinationSpaceErr, 2)

For nr = 0 To iSF

destinationSpaceErr(nr, j) = False

For i = 0 To j - 1

If destinationSpaceErr(nr, i) <> vbnullstring Then

destinationSpaceErr(nr, j) = True

Exit For

End If

Next

Next

End Function

' Wird aufgerufen wenn
Function resetErrFiles(nr)

Dim i, j

j = UBound(sourceFilesErr, 2)

For i = 0 To j - 1

If sourceFilesErr(nr, i) <> vbnullstring Then

sourceFilesErr(nr, i) = vbnullstring

copyCount(nr)  = copyCount(nr) + 1

End If

Next

j = UBound(sourceFolderErr, 2)

For i = 0 To j - 1

sourceFolderErr(nr, i) = vbnullstring

Next

j = UBound(destinationFileErr, 2)

For i = 0 To j - 1

destinationFileErr(nr, i) = vbnullstring

Next

j = UBound(delDestinationFileErr, 2)

For i = 0 To j - 1

delDestinationFileErr(nr, i) = vbnullstring

Next

j = UBound(destinationSpaceErr, 2)

For i = 0 To j - 1

destinationSpaceErr(nr, i) = vbnullstring

Next

End Function

Function scriptErrInfoMail()

If scriptErrTxt <> vbnullstring Then

If oWsh.popup("Info-E-Mail an Alant senden über neuen FehlerCode ? ", 30, cRS & " Robocopy.Log Error" , vbYesNo + vbquestion) = vbYes Then

s = "mailto: Diese E-Mail-Adresse ist gegen Spambots geschützt! JavaScript muss aktiviert werden, damit sie angezeigt werden kann. ?Subject=Robocopy.Log%20neuer%20Fehler%20aufgetreten" & _

"&Body=Folgender%20Fehler-Code%20ist%20noch%20nicht%20erfasst:%0D%0D-----%0D" & scriptErrTxt & "%0D-----"

oWsh.Run wrap(s)

WScript.Sleep 5000

End If

End If

End Function

'Function get_
'End Function


Function logFiles()

Dim fLog, f, i, j, k, l, sTP, fEnd, sSS, sP, s, arr, sTlog

Const c = 40

Const cKopfZeilen = 15 'Anzahl Kpofzeilen

On Error Resume Next

If logging = 0 And emailInfo = 0 Then Exit Function

i = checkPath(logFile)

If i = 1 Then

logFile = Left(destination, 2) & Right(logFile, Len(logFile)- 2)

i = 3

ElseIf i = 0.5 Then

logFile = Left(destination, 2) & Right(logFile, Len(logFile)- 2)

i = 3  

End If

If i = 2 Or i = 3 Then

If oFS.fileExists(logFile) Then

ElseIf oFS.folderexists(logFile) = False Then

j = InStrRev(logFile, cBSlash, -1, vbTextCompare)

If j > 0 Then

If oFS.folderexists(logFile) = False Then

s = Left(logFile, j - 1)

sP = sCMD & cMD & wrap(s)

oWsh.Run sP, 0, True

WScript.sleep 5

End If

Else

logFile = logFile & cBSlash & cRC & cAppLog

End If

End If

Else

logFile = destination & iif(Right(destination, 1 ) =  cBSlash , vbnullstring, cBSlash) & cRC & cAppLog

End If

s = Left(logFile, 2)

Err.Clear

sTlog = sLog & "_tmp_rep" & cAppLog

Set fLog = oFS.opentextfile(sTlog, 2, True)

If Err.Number > 0 Then

logging = 0

Exit Function

End If

userHint "lf", logFile

fLog.writeline "### RoboCopy.Log Datei" & String(c - 22, "#") & vbcrlf & _

"N  -> neue Datei"  & vbcrlf & _

"U  -> neuere Dateiversion" & vbcrlf & _

"X  -> gelöschte Datei" & vbcrlf & _

"VZ -> Backup ist voll (nicht gesichert!)" & vbcrlf & _

"LS -> gesperrte Quelle (nicht gesichert!)" & vbcrlf & _

"LF -> gesperrter Quell-Ordner (nicht gesichert!)" & vbcrlf & _                                  

"LB -> gesperrter Backup-Ordner (nicht gesichert!)" & vbcrlf & _

"LZ -> gesperrtes Ziel (nicht gesichert!)" & vbcrlf & _

"LD -> nicht gelöschte Datei Ziel-LW" & vbcrlf & _

String(c, "#") & vbcrlf & _

vbcrlf & _

"[Sicherungsmedium]"

If rotationDays > 0 Then

s =  oWsh.RegRead(cReg & "NFO")& vbcrlf & oWsh.Regread(cReg & "DAT") & cK & oWsh.RegRead(cReg & "DD")

If Err.Number <> 0 Then  Err.Clear

Else

s = "-" & vbcrlf & "-"

End If

fLog.writeline s & vbcrlf

If sDateFolder = vbnullstring Then

s = getDateFolderName()

Else

s = Right(sDateFolder, Len(sDateFolder) - 1)

End If

fLog.writeline "[" & s & "]"

  'Zeilen des Kopfbereichs -> anpsssen!

For k = 0 To iSF

'    sTP = sLog & cUL & k & cAppLog

sTP = sLog & cDR & k & cAppLog

    'sSS = splitSource(s)

If oFS.fileexists(sTP) Then

Set f = oFS.OpenTextFile(sTP, 1, True)

If Err.Number <> 0 Then

Err.Clear

Else

Do Until f.AtEndOfStream

s = f.Readline

If s <> vbnullstring Then  

If InStr(1, s, chr(9)) > 0 Then

arr = Split(s, chr(9))

s = Trim(arr(1))

s2 = oem2ansiTxt(arr(4))                  

If s = vbnullstring Then

ElseIf s = "same" Or s = "gleich" Then

s = vbnullstring

ElseIf is_lockedSourceFilesErr(k, s2) Then

s =  "LS *" & s2 & "*"

ElseIf is_delDestinationFileErr(k, s2) Then

s =  "LD *" & s2 & "*"

ElseIf is_destinationFileErr(k, s2) Then

s =  "LZ *" & s2 & "*"

  '            ElseIf is_destinationSpaceErr(k, s2) then
  '              sP =  "VZ *" & s2 & "*"

ElseIf s = "Newer" Or s = "Neuer" Then

s = "U  " & s2

ElseIf s = "New File" Or s = "Neue Datei" Then

s = "N  " & s2

ElseIf s = "*EXTRA File" Or s = "*EXTRA Datei" Then

s = "X  " & s2

ElseIf s = "*named file" Or s = "*Benannte D" Then

s = "X  " & s2

              'ElseIf s = "" Or  s = "" then
              '  sP = cSpace

Else

s = vbnullstring

End If

ElseIf Right(s, 1) = cBSlash Then ' Wenn es Probleme mit ganzen Ordner gibt            

If is_sourceFolderErr(k, s) Then                

                'Wird als Ref zurückgegeben

s =  "LF *" & s & "*"            

              'elseIf is_backupFolderErr(k, s) then                
                'Wird als Ref zurückgegeben
              '  s =  "LB *" & s & "*"

Else

s = vbnullstring

End If                            

Else

s = vbnullstring

End If

If s <> vbnullstring Then fLog.writeline s

End If

Loop

f.close

End If

End If

Next

sP = get_destinationSpaceErr(True)

If sP <> vbnullstring Then

sP = "VZ *" & Replace(sP, vbcrlf, "*" & vbcrlf & "VZ *")

sP = Left(sP, Len(sP) - 6)

fLog.writeline sP

End If

fLog.writeline

Set f = oFS.OpenTextFile(logFile, 1, True)

If Err.Number = 70 Then

    'Erlaubnis verweigert.

userHint "logErr", logFile    

Err.Clear    

ElseIf Err.Number <> 0 Then

Err.Clear

Else

For i = 1 To cKopfZeilen 'Zeilen des Kopfbereichs

If Not f.AtEndOfStream Then f.SkipLine 's = f.Readline

Next

i = 1

fEnd = 0

Do Until f.AtEndOfStream Or fEnd

If logging = 3 Then

s = f.readall

Else

s = f.Readline

If Left(s, 1) = "[" Then

i = i + 1

If i > stages Then

fEnd = -1

s = vbnullstring

End If

End If

End If

fLog.writeline s

Loop

f.close

End If

fLog.close

s = sCMD & cDel & wrap(logFile)

oWsh.Run s, iif(showShell, 1, 0), True

s = sCMD & cMV & wrap(sTlog) & cSpace & wrap(logFile)

oWsh.Run s, iif(showShell, 1, 0), True

End Function

Function is_lockedSourceFilesErr(nr, sF)

Dim i, j, s

j = UBound(sourceFilesErr, 2) - 1

For i = 0 To j

s = sourceFilesErr(nr, i)

If s <> vbnullstring Then

If LCase(s) = LCase(sF) Then

sourceFilesErr(nr, i) = vbnullstring

is_lockedSourceFilesErr = True

Exit Function

End If

End If

Next

is_lockedSourceFilesErr = False

End Function

Function is_delDestinationFileErr(nr, sF)

Dim i, j, s

j = UBound(delDestinationFileErr, 2) - 1

For i = 0 To j

s = delDestinationFileErr(nr, i)

If s <> vbnullstring Then

If LCase(s) = LCase(sF) Then

delDestinationFileErr(nr, i) = vbnullstring

is_delDestinationFileErr = True

Exit Function

End If

End If

Next

is_delDestinationFileErr = False

End Function

Function is_sourceFolderErr(nr, sF)

Dim i, j, s

j = UBound(sourceFolderErr, 2) - 1

sf = LCase(sF)

For i = 0 To j

s = LCase(sourceFolderErr(nr, i))

If s <> vbnullstring Then

If Right(sf, Len(s)) = s Then

sourceFolderErr(nr, i) = vbnullstring

is_sourceFolderErr = True

sF = s

Exit Function

End If

End If

Next

is_sourceFolderErr = False

End Function

Function is_destinationFileErr(nr, sF)

Dim i, j, s

j = UBound(destinationFileErr, 2) - 1

sf = LCase(sF)

For i = 0 To j

s = LCase(destinationFileErr(nr, i))

If s <> vbnullstring Then

If Right(sf, Len(s)) = s Then

destinationFileErr(nr, i) = vbnullstring

is_destinationFileErr = True

sF = s

Exit Function

End If

End If

Next

is_destinationFileErr = False

End Function

' wird nicht in Log-Datei von Robocopy geschrieben
'Function is_destinationSpaceErr(nr, sF)
'  Dim i, j, s
'  j = Ubound(sourceFilesErr, 2) - 1
'  for i = 0 To j
'    s = destinationSpaceErr(nr, i)
'    If s <> vbnullstring then
'      If LCase(s) = LCase(sF) then
'        destinationSpaceErr(nr, i) = vbnullstring
'        is_destinationSpaceErr = True
'      Exit Function
'      End If
'    End If
'  Next
'  is_destinationSpaceErr = False
'End Function

Function checkDestination()

Dim wmi, f, i, j, svr, s, sVNS

  ' 0=Caption 1=VolumeName 2=VolumeSerialNumber 3=MediaType 4=DriveType 5=FileSystem

On Error Resume Next

lw = Left(destination, 2)

i = checkPath(destination)

  ' wenn Benennung vergeben ggf. anpassen

sVNS = check_volume2(volumeNameSerialNr, -1)

If i = 3 Then ' LW

ElseIf i = 2 Then

j = InStr(3, destination, cBSlash)

If Not sVNS = False Then

destination = sVNS & Right(destination, Len(destination) - j + 2)

Else

If j = 0 Then

        'Kein Unterordner angegeben auf dem Netzwerk

userHint "destErr", "SRV"

Else

s = UCase(Mid(destination, 3, i - 3))

If s <> arrReg(cServer) Then 'DName

svr = s

If Not oFS.FolderExists(destination) Then

s = sCMD & cMD & destination

j = oWsh.Run(s, iif(showShell, 1, 0), True)

If j <> 0 Then userHint "destErr", "WERR"

End If

s = mapNetworkLW()

If s <> vbnullstring Then

destination = s

lw = s

fNetworkLW = True

wmiP(cServer) = svr

Else

wmiP(cServer) = "-"

End If

Else

          'Netzwerk-LW bekannt

checkDestination = True

Exit Function

End If

End If

End If

ElseIf i = 1 Then '?

lw = Left(sSP, 2)        

destination = lw & Right(destination, Len(destination) - InStr(1, destination, cBSlash) + 1)

ElseIf i = 0.5 Then

lw = Left(sSP, 2)        

destination = lw

Else

userHint "destErr", "OZLW"

End If

If sVNS = False Then

    'nichts gefunden also

ElseIf UCase(sVNS) = UCase(lw) Then

    'keine Änderung da LW korrekt

Else

lw = sVNS

If i = 2 Then

destination = LW & Right(destination, Len(destination) - 3)

ElseIf i = 3 Or i= 1 Then

destination = LW & Right(destination, Len(destination) - 2)

Else

End If

userHint "lwNameChange", vbnullString

End If

  ' LW Parameter abrufbar?

Set oWmi = GetObject("winmgmts:\\.\root\cimv2:Win32_LogicalDisk.DeviceID='" & LW & "'")

If IsEmpty(oWmi) Or IsNull(oWmi) Then userHint "destErr", "LW"

With oWmi

wmiP(0) = UCase(NZ(.Caption, vbnullstring))

wmiP(cVolumeName) = UCase(NZ(.VolumeName, vbnullstring))

wmiP(cVolumeSerialNumber) = UCase(NZ(.VolumeSerialNumber, vbnullstring))

wmiP(cMediaType) = NZ(.MediaType, 0)

wmiP(cDriveType) = NZ(.DriveType, 0)

wmiP(cFileSystem) = UCase(NZ(.FileSystem, vbnullstring))

End With

  ' Prüfen ob Backup-LW ein DVD-LW ist bzw. USB ohne Gerät

If wmiP(2) = vbnullstring And wmiP(3) = 0 Then 'LW-Buchstabe zwar vergeben aber nicht angeschlossen

If wmiP(4)= 2 Then

userHint "destErr", "USB"

ElseIf wmiP(4) = 5 Then

userHint "destErr", "DVD"

Else

userHint "destErr", "LW_P"

End If

End If

  ' Hard-Links möglich ?

If hlnk > 0 And stages > 1 Then

If wmiP(5) <> "NTFS" Then

hlnk = 0

userHint "hlnkErr", wmiP(5)

End If

End If

checkDestination = True

On Error Goto 0

End Function

Function checkWriting()

Dim s,i

On Error Resume Next

If Not oFS.FolderExists(destination) Then

s = sCMD & cMD & destination

i = oWsh.Run(s, 0, True)

If i = 0 Then

Else

userHint "destErr", "WERR"

End If

Else

Set oF = oFS.GetFolder(destination)

If oF.attributes = 1 Then 'nur lesen

userHint "destErr", "WERR"

End If

If Len(destination) = 2 Then

s = destination & cBSlash & "~tmp" & Int( ( 100 - 1 + 1 ) * Rnd + 1 )

Set of = oFs.createfolder(s)

If Err.Number > 0 Then

Err.Clear

userHint "destErr", "WERR"

Else

Set oF = Nothing

s = sCMD & "RD /Q " & s

oWsh.Run s, 0, True

End If            

Else

s = destination & "\~tmp" & Int((100 - 1 + 1) * Rnd + 1) & cAppLog

Set oF = oFS.opentextfile(s, 8, True)

If Err.Number > 0 Then

Err.Clear

userHint "destErr", "WERR"

Else

Set oF = Nothing

s = sCMD & cDel & s

oWsh.Run s, 0, True

End If

End If

End If

checkWriting = True

On Error Goto 0

End Function

Function checkSource()

Dim f, i, s

On Error Resume Next

f = False

For i = 0 To UBound(sourceFolders)

If Left(sourceFolders(i), 2) = "?:" Then sourceFolders(i) = Left(sSP, 2) & Right(sourceFolders(i), Len(sourceFolders(i)) - 2)

If oFS.folderexists(sourceFolders(i)) Then

If LCase(destination) = LCase(sourceFolders(i)) Then

userHint "destErr", "ZLW"

End If

f = True

Else

s = "-? " & i + 1 & ". Quell-Pfad falsch : " & sourceFolders(i)

userHint "source", s

sourceFolders(i) = "-" & sourceFolders(i)

End If

Next

If Not f Then userHint "srcErr", vbnullstring

On Error Goto 0

End Function

'Welchen Usergruppen gehört der Script-Benutzer an
Function checkUserIsAdmin()

Dim oUser, oGroups, oGroup, sUser, f

sUser = oWsh.ExpandEnvironmentStrings("%USERNAME%")

s = oWsh.ExpandEnvironmentStrings("%USERDOMAIN%") & "/" & sUser

  'Dauert etwas ~1 Sek.

Set oUser = GetObject("WinNT://" & s)

i = 1

ReDim userGroupList(i)

userGroupList(0) = False

For Each oGroup In oUser.Groups

userGroupList(i) = oGroup.Name

i = i + 1

ReDim Preserve userGroupList(i)

If LCase(oGroup.Name) = "administrators" Or LCase(oGroup.Name) = "administratoren" Then

userGroupList(0) = True

End If

Next

userGroupList(i) = sUser

  'Sollte der User per Script zeitweise Admin-Rechte haben dann hiermit herausbekommen

If userGroupList(0) = False Then

On Error Resume Next

    'Die Datei _default.pif im Windowsordner verschieben kann nur ein Administrator

s = oWsh.ExpandEnvironmentStrings("%SystemRoot%") & "\_default.pif"

Set f = oFS.GetFile(s)

f.Move (s & cUL)

Set f = Nothing

If Err.Number > 0 Then

Err.Clear

Else

userGroupList(0) = True

Set f = oFS.GetFile(s & cUL)

f.Move (s)

Set f = Nothing

End If

On Error Goto 0

End If

End Function

Function forceDelete(Ordner)

Dim Folder, subFolder, fFile, f1, fo, s

On Error Resume Next

s = oWsh.Run(sCMD & cRD & wrap(Ordner), 0, True)

If oFS.folderexists(Ordner) Then

Set Folder = oFS.getfolder(Ordner)    

    'Sollten die Dateien schreibgeschützt sein diesen Schutz aufheben

s = "ATTRIB -R " & wrap(Folder.Path & "\*.*")

oWsh.run s, 0, True

    'Sollte der Ordner schreibgeschützt sein diesen Schutz aufheben

s =  "ATTRIB -R " & wrap(Folder.Path)

oWsh.run s, 0, True

    'Jetzt endlich löschen

s = sCMD & cDel & wrap(Folder.Path & "\*.*")

oWsh.Run s, 0, True

For Each fFile In Folder.files

Set f1 = oFS.GetFile(fFile.path)

f1.Delete

If Err.Number = 70 Then

s = sCMD & cDel & wrap(fFile.Path)

oWsh.Run s, 0, True

End If

Next

For Each subFolder In Folder.SubFolders

s = sCMD & cRD & wrap(subFolder.Path)

oWsh.Run s, 0, True

s = subFolder.Path

Set fo = oFS.getfolder(s)

fo.delete

If Err.Number = 70 Then

Err.Clear

forceDelete s

fo.delete

End If

Next

s = sCMD & cRD & wrap(Ordner)

oWsh.Run s, 0, True

End If

On Error Goto 0

End Function

Function checkVSSProg()

Dim s

vssProg = LCase(Left(vssProg, 1))

checkVSSProg = True

Select Case vssProg

Case "s", "shadowcopy", "shadow", "scopy": vssProg = "ShadowCopy"

Case "h", "hobocopy",   "hobo",   "hcopy": vssProg = "HoboCopy"

Case Else

checkVSSProg = False

userHint "vssErr", s

End Select

End Function

Function Beeep(itimes)

Dim itemp

For itemp = 1 To itimes

WScript.echo Chr(7)

Next

End Function

' Umlaute in Dateinamen werden von RoboCopy als als OEM-Zeichen in den LOG-Dateien gespeichert.
' oem2ansi wandelt diese in Umlaute zurück.
Function oem2ansi(sOEM)

Dim oOEM, oANSI, s

On Error Resume Next

Set oOEM = oFS.OpenTextFile(sOEM, 1, False, -2)

If Err.Number = 0 Then

Set oANSI = oFS.OpenTextFile(sOEM & cUL, 2, True, -2)

Do Until oOEM.AtEndOfStream

s = Asc(oOEM.Read(1))

With oANsi

Select Case s

Case 142  : .Write Chr(196)  'Ä

Case 153  : .Write Chr(214)  'Ö

Case 154  : .Write Chr(220)  'Ü

Case 132  : .Write Chr(228)  'ä

Case 148  : .Write Chr(246)  'ö

Case 129  : .Write Chr(252)  'ü

Case 225  : .Write Chr(223)  'ß

Case Else : .Write Chr(s)

End Select

End With

Loop

oOEM.Close

oANSI.Close

s = sCMD & cDel & sOEM

oWsh.Run s, 0, True

WScript.sleep 50

s = sCMD & cMV & sOEM & cUL & cSpace & sOEM

oWsh.Run s, 0, True

WScript.sleep 50

Else

Err.Clear

End If

End Function

Function oem2ansiTxt(sOEM)

Dim s

s = Replace(sOEM, chr(142), Chr(196)) 'Ä

s = Replace(s, chr(153), Chr(214))    'Ö

s = Replace(s, chr(154), Chr(220))    'Ü

s = Replace(s, chr(132), Chr(228))    'ä

s = Replace(s, chr(148), Chr(246))    'ö

s = Replace(s, chr(129), Chr(252))    'ü

s = Replace(s, chr(225), Chr(223))    'ß

oem2ansiTxt = s

End Function

' Zeichenkette in single umwandeln
Function stringToSingle(s)

If CSng("1.1") = 1.1 Then

stringToSingle = CSng(Replace(s, cK, cD))

Else

    'Komma als Nachkommatrenner

stringToSingle = CSng(Replace(s, cD, cK))

End If

End Function

' Zahl in Bytes umrechnen
Function convertToByte(s, factor)

Select Case factor

Case "k" convertToByte = s * 1024

Case "m" convertToByte = s * 1024 * 1024

Case "g" convertToByte = s * 1024 * 1024 * 1024

Case "t" convertToByte = s * 1024 * 1024 * 1024 * 1024

Case "b" convertToByte = s

End Select

End Function

Function crypt(Inp, Mode)

Const cKey = "si_oU75&iacut;EkO19drslI"

Dim z, i, Position, cptZahl, orgZahl, keyZahl, cptString

For i = 1 To Len(Inp)

Position = Position + 1

If Position > Len(cKey) Then Position = 1

keyZahl = Asc(Mid(cKey, Position, 1))

If Mode Then

      ' Verschlüsseln'

orgZahl = Asc(Mid(Inp, i, 1))

cptZahl = orgZahl Xor keyZahl

cptString = Hex(cptZahl)

If Len(cptString) < 2 Then cptString = "0" & cptString

z = z & cptString

Else

      ' Entschlüsseln'

If i > Len(Inp) \ 2 Then Exit For

cptZahl = CByte("&H" & Mid(Inp, i * 2 - 1, 2))

orgZahl = cptZahl Xor keyZahl

z = z & Chr(orgZahl)

End If

Next

Crypt = z

End Function

Function writableByUser(sFolder)

Dim CONTROL_FLAGS ' ControlFlags Werte

Dim ACCESS_MASK ' AccessMask Werte

  'Dim ACE_FLAGS ' AceFlags Werte
  'Dim ACE_TYPE ' AceType Werte

Dim Key ' Dictionary Objektschlüssel

Dim i ' Zähler

Dim wmiServices ' SWbemServices Objekt

Dim wmiSecuritySettings 'Win32_LogicalFileSecuritySetting

Dim wmiSecurityDescriptor ' Win32_SecurityDescriptor

Dim wmiOwner ' Win32_Trustee

Dim wmiAce ' Win32_ACE

Dim wmiTrustee ' Win32Trustee

Dim arrDacl ' DACL Array

Dim arrSacl ' SACL Array

Dim f

  'on Error Resume Next

f = False

Set CONTROL_FLAGS = CreateObject("Scripting.Dictionary")

CONTROL_FLAGS.Add "SE_OWNER_DEFAULTED", 1

CONTROL_FLAGS.Add "SE_GROUP_DEFAULTED", 2

CONTROL_FLAGS.Add "SE_DACL_PRESENT", 4

CONTROL_FLAGS.Add "SE_DACL_DEFAULTED", 8

CONTROL_FLAGS.Add "SE_SACL_PRESENT", 16

CONTROL_FLAGS.Add "SE_SACL_DEFAULTED", 32

CONTROL_FLAGS.Add "SE_DACL_AUTO_INHERIT_REQ", 256

CONTROL_FLAGS.Add "SE_SACL_AUTO_INHERIT_REQ", 512

CONTROL_FLAGS.Add "SE_DACL_AUTO_INHERITED", 1024

CONTROL_FLAGS.Add "SE_SACL_AUTO_INHERITED", 2048

CONTROL_FLAGS.Add "SE_DACL_PROTECTED", 4096

CONTROL_FLAGS.Add "SE_SACL_PROTECTED", 8192

CONTROL_FLAGS.Add "SE_SELF_RELATIVE", 32768

Set ACCESS_MASK = CreateObject("Scripting.Dictionary")

ACCESS_MASK.Add "FILE_LIST_DIRECTORY", 1

ACCESS_MASK.Add "FILE_ADD_FILE", 2

ACCESS_MASK.Add "FILE_ADD_SUBDIRECTORY", 4

ACCESS_MASK.Add "FILE_READ_EA", 8

ACCESS_MASK.Add "FILE_WRITE_EA", 16

ACCESS_MASK.Add "FILE_TRAVERSE", 32

ACCESS_MASK.Add "FILE_DELETE_CHILD", 64

ACCESS_MASK.Add "FILE_READ_ATTRIBUTES", 128

ACCESS_MASK.Add "FILE_WRITE_ATTRIBUTES", 256

ACCESS_MASK.Add "DELETE", 65536

ACCESS_MASK.Add "READ_CONTROL", 131072

ACCESS_MASK.Add "WRITE_DAC", 262144

ACCESS_MASK.Add "WRITE_OWNER", 524288

ACCESS_MASK.Add "SYNCHRONIZE", 1048576

  'Set ACE_FLAGS = CreateObject("Scripting.Dictionary")
  'ACE_FLAGS.Add "OBJECT_INHERIT_ACE", 1
  'ACE_FLAGS.Add "CONTAINER_INHERIT_ACE", 2
  'ACE_FLAGS.Add "NO_PROPAGATE_INHERIT_ACE", 4
  'ACE_FLAGS.Add "INHERIT_ONLY_ACE", 8
  'ACE_FLAGS.Add "INHERITED_ACE", 16
  'ACE_FLAGS.Add "SUCCESSFUL_ACCESS_ACE_FLAG", 32
  'ACE_FLAGS.Add "FAILED_ACCESS_ACE_FLAG", 64

  'Set ACE_TYPE = CreateObject("Scripting.Dictionary")
  'ACE_TYPE.Add 0, "Access Allowed"
  'ACE_TYPE.Add 1, "Access Denied"
  'ACE_TYPE.Add 2, "Audit"

  ' Verbindung per WMI mit dem ZielComputer

If Not IsArray(userGroupList) Then checkUserIsAdmin

s = oWsh.ExpandEnvironmentStrings("%COMPUTERNAME%")

  's = "winsbs08"

Set wmiServices = GetObject("winmgmts:{impersonationLevel=Impersonate}!\\" & s)

  ' Hole die ZielOrdner bwz. ZielDatei Sec.-Einstellungen

Set wmiSecuritySettings = wmiServices.Get("Win32_LogicalFileSecuritySetting.Path='" & sFolder & "'")

  ' Hole die ZielOrdner bwz. ZielDatei Sec.-Descriptor

i = wmiSecuritySettings.GetSecurityDescriptor(wmiSecurityDescriptor)

  ' Sec.-Descriptor Owner über die Win32_Trustee Instanz

Set wmiOwner = wmiSecurityDescriptor.Owner

If CONTROL_FLAGS("SE_DACL_PRESENT") And wmiSecurityDescriptor.ControlFlags Then

arrDacl = wmiSecurityDescriptor.DACL

For Each wmiAce In arrDacl

Set wmiTrustee = wmiAce.Trustee

      'WScript.Echo " Trustee Name: " & wmiTrustee.Name

For i = 0 To UBound(userGroupList)

If wmiTrustee.Name = userGroupList(i) Then

          'WScript.Echo " AccessMask........."

For Each Key In ACCESS_MASK.Keys

If ACCESS_MASK(Key) And wmiAce.AccessMask Then

              'WScript.Echo cSpace & Key

If Key = "FILE_WRITE_EA" Then

f = True

Exit For

End If

End If

Next

'          WScript.Echo " AceFlags..........."
'          For Each Key in ACE_FLAGS.Keys
'            If ACE_FLAGS(Key) And wmiAce.AceFlags Then
'                    WScript.Echo cSpace & Key
'            End If
'          Next

End If

Next

If f = True Then Exit For

Next

End If

If Not f And CONTROL_FLAGS("SE_SACL_PRESENT") And wmiSecurityDescriptor.ControlFlags Then

arrDacl = wmiSecurityDescriptor.SACL

For Each wmiAce In arrSacl

Set wmiTrustee = wmiAce.Trustee

      'WScript.Echo "Trustee Name: " & wmiTrustee.Name

For i = 0 To UBound(userGroupList)

If wmiTrustee.Name = userGroupList(i) Then

          'WScript.Echo " AccessMask........."

For Each Key In ACCESS_MASK.Keys

If ACCESS_MASK(Key) And wmiAce.AccessMask Then

              'WScript.Echo cSpace & Key

If Key = "FILE_WRITE_EA" Then

f = True

Exit For

End If

End If

Next

End If

Next

'        WScript.Echo " AceFlags..........."
'        For Each Key in ACE_FLAGS.Keys
'            If ACE_FLAGS(Key) And wmiAce.AceFlags Then
'              WScript.Echo cSpace & Key
'            End If
'        Next

If f = True Then Exit For

Next

End If

writableByUser = f

End Function

' Scriptdauer ermitteln
Function scriptdauer(f)

On Error Resume Next

If f Then

duration = Time

Else

duration = DateDiff("s", duration, Time) + 0.5

If duration > 60 Then

duration = CInt(duration / 60) & " Min. " & duration Mod 60

ElseIf duration = 0 Then

duration = "< 1 "

Else

duration = duration

End If

duration = "Ablaufdauer : " & duration & " Sek."

sInfo = Replace(sInfo, "|#|",duration)

End If

On Error Goto 0

End Function

Sub robocopyHta()

If help = "?" Then

oWsh.Run sSP & "robocopy.hta " & cDQ & roboCopyIni & cDQ, 0

WScript.Quit

End If

End Sub

Function deleteFile(sFile)

Dim i, j

j = UBound(excludeFiles)

For i = 0 To j

If sFile Like excludeFiles(i) Then

s = sCMD & cDel & wrap(sFile)

oWsh.Run s, 0, True

Exit For

End If

Next

End Function

'*****************************************************************************************
'--- trueCrypt Section -------------------------------------------------------------------
'*****************************************************************************************
Function mountTrueCrypt()

Dim s, wmi, oi, ois, i

i = checkPath(destination)

If i = 0 Or i = -1 Then

destination = "H:"

ElseIf i = 2 Then 'LAN

userHint "destErr", "TCN"

ElseIf i = 3 Then

If asc(UCase(Left(destination, 1))) < 67 Then

      'Bei A: und B: kam in XP ein Dialogfenster und musste mit OK quittiert werden

destination = "H" &  Right(destination, Len(destination) - 1)

Else

      'OK

End If

ElseIf i = 1 Then

    ' Sollte kein LW angebeben worden sein dann mit H beginnen

destination = "H:" & Right(destination, Len(destination) - InStr(1, destination, cBSlash) + 1)

ElseIf i = 0.5 Then

destination = "H:"

Else

userHint "destErr", "TCN"

End If

getTrueCryptFile()

lw = Left(destination, 1)

sm = check_volume2(tcSoftmount, -1)

TruecryptShortcut()

  '1. Truecrypt starten alle lw dismounten

dismountTrueCrypt(iif(tcShortcut<>vbnullstring, False, True))

v = checkTrueCryptVolume()

If v = True Then

If InStr(1, tcVolume, "\Device\Harddisk") Then

      ' Partition wird gemountet

Else

Set oF = oFS.getfile(tcVolume)

If oF.attributes = 1 Then

v = False

Else

v = True

End If

      'v = writableByUser(tcVolume)

End If

If v = True Then

    'TrueCryptParameter()

If sm = False Then

v = mount_truecrypt_container()

Else

destination = sm & Right(destination, Len(destination) - 2)

End If

If v = True Then

        'v = UCASE(lw)

userHint "tcmounted", vbnullstring

Else

userHint "tcErr", "mountErr"

End If

Else

      'user hat keine Schreibrechte an der TC-Datei

userHint "tcErr", "noWritePermission"

End If

Else

    'dismountTrueCrypt()

userHint "destErr", v

End If

End Function

Function dismountTrueCrypt(f)

If sm = False Then

dismount_truecrypt_container()

If f Then kill_tc()

End If

End Function


' Es wird versucht ein LW zu mounten.
' Sollte der LW-Buchstabe schon besetzt sein, wird versucht nach einem freien LW zu suchen.
Function mount_truecrypt_container()

Dim tc, i, j, s

Dim drv, drvlst

i = False

If tcKeyfile <> vbNullString Then

If oFS.fileexists(tcKeyfile) Then

tcKeyfile = " /k " & wrap(tcKeyfile)

Else

userHint "tcErr", "NoKeyFile"

End If

End If

If tcPassword <> vbNullString Then tcPassword = " /p " & wrap(tcPassword)

If tcVolume <> vbNullString Then tcVolume = " /v " & wrap(tcVolume)

Set drvlst = oFS.Drives

userHint "tcMount", vbNullString

Do

j = True

For Each drv In drvlst

If UCase(drv.DriveLetter) = UCase(lw) Then j = False

Next

If j = True Then

s = TrueCryptProg & cSpace & tcVolume & tcKeyfile & tcPassword & " /q /s /l " & lw & " /f" ' /m rm 'Ohne wird die VolumenSerienNr. nicht übertragen

      'Einkommentieren um die Befehlzeile kopieren zu können
      'InputBox "Startaufruf um TC zu mounten", "Nur zur Info / Test", s

j = 0

Set tc = oWsh.Exec(s)

Do While tc.Status = 0 Or j > 10000

WScript.Sleep 100

j = j + 100

Loop

      'Kein Rückgabefehler

If tc.exitCode = 0 Then i = True

End If

If UCase(lw) = "Z" Then i = True

j = Asc(lw)+1

lw = Chr(j)

Loop Until i = True

lw = Chr(j - 1)

mount_truecrypt_container = False

If IsObject(tc) Then

If tc.exitCode = 0 And oFS.DriveExists(lw & ":") Then

destination = lw & Right(destination, Len(destination) - 1)

mount_truecrypt_container = True

End If

End If

End Function

Function kill_tc()

Dim programm

Dim wmi, col, obj

Const CS = "Select * from Win32_Process Where Name = "

  'Wie heist der PC
'  Const PC = "localhost"

programm = "'TrueCrypt.exe'"

Set wmi = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")

Set col = wmi.ExecQuery (CS & programm )

For Each obj In col

obj.Terminate()

Next

programm = "'TrueCr~1.exe'"

Set col = wmi.ExecQuery (CS & programm )

For Each obj In col

obj.Terminate()

Next

End Function

Function dismount_truecrypt_container

Dim wmi, system, process, f, s', j

Const PROGRAMM = "truecrypt.exe"

Const PROGRAMM1 = "truecr~1.exe"

f = False

s = TrueCryptProg & " /d /f"

oWsh.run s, iif(showShell, 1, 0)

WScript.sleep 2000 'kleine Wartezeit falls das Beenden etwas dauert.

'  Set wmi = oWsh.Exec(s)
'  j = 0
'  Do While wmi.Status = 0 Or j > 10000
'    WScript.Sleep 100
'    j = j + 100
'  Loop

If tcShortcut <> vbnullstring Then

Set wmi = GetObject("winmgmts:")

Set system = wmi.instancesOf("win32_process")

For Each process In system

If LCase(process.name) = PROGRAMM Or LCase(process.name) = PROGRAMM1 Then

With oWsh

f = .AppActivate("TrueCrypt")

If f Then

.SendKeys tcShortcut 'Alt+STRG+SHIFT+0

WScript.sleep 1000 'kleine Wartezeit falls das Beenden etwas dauert.

End If

End With

End If

Next

End If

  'sollte es über die Tastenkombination nicht geklappt haben dann über eine 2. Instanz
End Function

Function checkTrueCryptVolume()

Dim i, j, s, s2, s3

Dim wmi, wmiDrv, wmiPart

On Error Resume Next

i = checkPath(tcVolume)

If i = 0 = vbnullstring Then

userHint "tcErr" , "noVolume"

ElseIf InStr(1, tcVolume, "\Device\Harddisk") = 1 Then

j = InStr(1, tcVolume ,"\Harddisk")

s = Mid(tcVolume, j + 9, 1)

s2 = Right(tcVolume, 1)

i = CInt(s2)

Set wmi = GetObject("winmgmts:!root\cimv2")

For Each wmiDrv In wmi.InstancesOf("Win32_DiskDrive")

s3 = Replace(wmiDrv.DeviceID, "\\.\PHYSICALDRIVE" , vbNullString)

If s = s3 Then

s = "ASSOCIATORS OF {Win32_DiskDrive.DeviceID=""" & Replace(wmiDrv.DeviceID, cBSlash, c2BSlash) & """} WHERE AssocClass = Win32_DiskDriveToDiskPartition"

For Each wmiPart In wmi.ExecQuery(s)

j = CInt(Right(wmiPart.DeviceID, 1)) + 1

If i = j Then

s = True

Exit For

End If

Next

Exit For

End If

Next

If Not s = True Then

userHint "tcErr" , "wrongPartition"

End If

ElseIf i = 2 Then

    'LAN

ElseIf i = 3 Then

If LCase(lw) = LCase(Left(tcVolume, 1)) Then

    'Buchstabe auf den gemountet wird ist gleich dem Container

If UCase(lw) = lw Then

        'Durch den Groß-Buchstaben ist es erlaubt weiter LW-Buchstaben zu testen

Else

userHint "tcErr" , "same"

End If

End If

If Not oFS.fileExists(tcVolume) Then

userHint "tcErr" , "wrongPath"

End If

ElseIf i = 1 Then   ' = "M:\Louis\DatenSave" '"\Device\Harddisk1\Partition1"

tcVolume = LW & Right(tcVolume, Len(tcVolume) - InStr(1, tcVolume, cBSlash) + 1)

End If

checkTrueCryptVolume = True

On Error Goto 0

End Function

' A.) Ist ein Truecrypt-Container gemountet und soll nicht aus dem Dateisystem ausgehängt werden dann muss er unter Softmount mit seinem Name oder SerienNr angegeben werden.
' B.) Wenn der LW-Buchstabe des Zielpfades falsch ist kann hierüber der korrekte Buchstabe ermittelt werden im Array volumeNameSerialNr angegeben
Function check_volume2(arr, fGetLW)

Dim i, wmi, oi, ois

check_volume2 = False

If arr(0) <> vbNullString Then

Set wmi = GetObject("winmgmts://./root\cimv2")

Set ois = wmi.InstancesOf("Win32_LogicalDisk",48)

For Each oi In ois

For i = 0 To UBound(arr)

If UCase(oi.VolumeName) = UCase(arr(i)) Or UCase(oi.VolumeSerialNumber) = UCase(arr(i)) Then

          'lw = Left(oi.Caption, 1)

Set ois = Nothing

Set wmi = Nothing

If fGetLW Then

check_volume2 = oi.Caption

Else

check_volume2 = True

End If

Exit Function

End If

Next

Next

End If

End Function

Function truecryptShortcut

If tcShortcut <> vbnullstring Then

tcShortcut = Replace(Replace(Replace(Replace(Replace(tcShortcut, "UMSCHALTTASTE", "+"), "HOCHSCHALTTASTE", "+"), "UMSCHALT", "+"),"UMSCH", "+"), "STRG" , "^")

tcShortcut = Replace(Replace(Replace(Replace(tcShortcut, "ALT", "%"), "SHIFT" , "+"), "CTRL", "^"), "-", vbnullstring)

End If

End Function

Function getTrueCryptFile()

Const cT = "TrueCrypt.exe"

Const cTF = "TrueCrypt\"

  'TrueCrypt-Pfad herausbekommen

TrueCryptProg = oWsh.ExpandEnvironmentStrings("%ProgramFiles%") & cBSlash & cTF & cT 'c:\Programme

If Not oFS.FileExists(trueCryptProg) Then

TrueCryptProg = oWsh.ExpandEnvironmentStrings("%SystemDrive%") & cBSlash & cTF &  cT 'c:\

If Not oFS.fileexists(trueCryptProg) Then

TrueCryptProg = sSP & cT 'Scriptpfad

If Not oFS.FileExists(trueCryptProg) Then

TrueCryptProg = sSP & cTF &  cT 'Scriptpfad

If Not oFS.FileExists(trueCryptProg) Then

userHint "tcErr", "tcProg"

End If

End If

End If

End If

End Function

Function Iif(v, vTrue, vFalse)

If v Then

IIf = vTrue

Else

IIf = vFalse

End If

End Function

'*****************************************************************************************
'--- E-Mail Section ---------------------------------------------------------------
'*****************************************************************************************

Function sendEMail()

Dim oConf, oMsg, s

Const cdoSendUsingPort = 2 ' interne Konstante

Const cdoBasic = 1

Const c = "http://schemas.microsoft.com/cdo/configuration/"

Const cdoSendUsingMethod = "sendusing"

Const cdoSMTPServer = "smtpserver"

Const cdoSMTPConnectionTimeout = "smtpconnectiontimeout"

Const cdoSMTPAuthenticate = "smtpauthenticate"

Const cdoSendUserName = "sendusername"

Const cdoSendPassword = "sendpassword"

Const cdoURLProxyServer = "urlproxyserver"

Const cdoURLProxyBypass = "urlproxybypass"

Const cdoURLGetLatestVersion = "urlgetlatestversion"

' Erzeuge CDO-Objektreferenzen (ab CDO 2.x)

sInfo = Replace(Replace(sInfo, "|@|", vbnullstring), "$", String(68, "-"))

Select Case emailInfo

Case 0 : Exit Function

Case 1

Case 2 : If fInfo < 2 Then Exit Function

Case 3

End Select

If emailFrom  = vbnullstring Or emailUser = vbnullstring Or emailPassword = vbnullstring Or smtpServer = vbnullstring Then

emailErr = "SMPT-Daten unvollständig"

userHint "email", False

Else

If emailReceiver = vbnullstring Or emailReceiver = "from" Then emailReceiver = emailFrom

Set oConf = WScript.CreateObject("CDO.Configuration")

Set oMsg = WScript.CreateObject("CDO.Message")

With oConf.Fields ' Server-Eigenschaften setzen

.Item(c & cdoSendUsingMethod) = cdoSendUsingPort

.Item(c & cdoSMTPServer) = smtpServer

.Item(c & cdoSMTPConnectionTimeout) = 20

.Item(c & cdoSMTPAuthenticate) = cdoBasic

.Item(c & cdoSendUserName) = emailUser

.Item(c & cdoSendPassword) = emailPassword

.Item(c & cdoURLProxyServer) = vbnullstring

.Item(c & cdoURLProxyBypass) = vbnullstring

.Item(c & cdoURLGetLatestVersion) = True

.Update

End With

On Error Resume Next

With oMsg ' Nachricht erstellen

Set .Configuration = oConf ' setze Config-Daten

.From              = emailFrom ' Sender

.To                = emailReceiver ' Empfänger

.Subject           = emailSubject ' Betreff

.TextBody          = sInfo

      '.HTMLBody = vbnullstring

If logging > 0 Then

.AddAttachment logFile

End If

'      If UBound(emailAttachments)>0 then
'        for i = 0 To UBound(emailAttachments) - 1
'         .AddAttachment emailAttachments(i) 'GetPath & "TestReport.txt"
'        Next
'      End If

.SEnd ' jetzt absenden

End With

s = Err.Description

If s <> vbnullstring Then

Err.Clear

If InStr(1, s, "0x80040217") Then

        'Die Nachricht konnte nicht an den SMTP-Server gesendet werden. Der Transportfehlercode lautet 0x80040217. Die Serverantwort lautet Not available

emailErr = "Falscher Benutzername oder Passwort "

ElseIf InStr(1, s, "keine Verbindung zum Server") Then

       'Der Transport konnte keine Verbindung zum Server herstellen

emailErr = "Falscher SMTP-Server bzw. Server nicht erreichbar"

ElseIf InStr(1, s, ": 550") Or InStr(1, s, ": 553") Or InStr(1, s, " 5.1.1") Then

        'Der Server hat eine oder mehrere Empfängeradressen zurückgewiesen. Die Serverantwort lautet: 550 5.1.1 < Diese E-Mail-Adresse ist gegen Spambots geschützt! JavaScript muss aktiviert werden, damit sie angezeigt werden kann. >: Recipient address rejected: ...

emailErr = "Falsche Empfängeradresse "

ElseIf InStr(1, s, ": 552") Or InStr(1, s, "quota exceeded") Then

emailErr = "Postfach beim Empfänger überfüllt "

Else

emailErr = s

End If

s = False

Else

s = True

emailErr = vbnullstring

End If

userHint "email", s

End If

If emailErr <> vbnullstring Then emailErr = cAS & emailErr & vbcrlf

sInfo = Replace(sInfo, "|@|", emailErr)

End Function

'*****************************************************************************************
'--- Ende E-Mail Section ---------------------------------------------------------------
'*****************************************************************************************

'--- mapNetworkLW() -------------------------------------------------------------------
Function mapNetworkLW()

Dim oNetw, nl, sLW , j, k, l, z

Set oNetw = WScript.CreateObject("WScript.Network")

Set nl = oNetw.EnumNetworkDrives

  'If changeNetzwerkPath = True Then

mapNetworkLW = vbNullString

z = 90

j = 65

l = nl.count - 1

For i = j To z 'G To Z

sLW = Chr(i)& ":"

If Not oFS.DriveExists(sLW) Then

j = 0

For k = 0 To l Step 2

s = UCase(nl.item(k))

If s = sLW Then

j = 2 'Gibt's schon also zum nächsten Buchstaben

Exit For

End If

Next

If j = 0 Then

s = "net use " & sLW & cSpace & destination & " /persistent:no"  'T: \\Servername\Freigabe Passwort /user:Benutzer  /persistent:no

j = oWsh.Run(s, 0, True)

          'oNetw.MapNetworkDrive sLW & ":", destination, False

End If

If j = 0 Then '2 Fehler LW-Buchstabe schon vergeben

If oFS.driveexists(sLW) Then

mapNetworkLW = sLW

Exit For

End If

End If

End If

Next

End Function

Function dismapNetworkLW()

If fNetworkLW = True Then

s = "net use " & LW &  " /delete"

j = oWsh.Run(s, 0, True)

End If

End Function