Option Explicit

'...............................................................................................
'... rar.vbs 1.08   Autor: Michael Hölldobler hoelldobler[at]alant.de
'... Script benötigt eine Version des Rar-Packers
'... Packen:    rar.vbs (-Parameter1) (-Parameter2) (-..) Archiv-Pfad (Quelle1) (Quelle2) (..)
'... Entpacken: rar.vbs x (-p) Entpack-Ziel-Pfad Archiv.rar
'... Parameter:
'...   -pPasswort
'...   -hpPasswort (Ordnerstruktur verbergen)
'...   -bf Backup-Typ full (default) -bi (incremental)
'...   -fr Fileformat RAR(default) -fz ZIP
'...   -a1 Anzahl Datei-Versionen 1(default)
'...   -v1000 maximale Dateigröße danach wird gesplittet kb
'...   -sfx Selbstentpackendes Archiv.exe erzeugen
'...   -ep3 Jedes LW In eingenem Pfad sichern
'...   -rr oder -rr500 (Sectoren) oder % -rr3%  WiederherstellungsInformationen(1%)
'...   -n*.doc Filter Einschränkungen    (mehrfach möglich -n*.pdf -n*.xls)
'...   -x<file>  diese Datei ausschließen (mehrfach möglich -x*.tmp -x*.mp3)
'...
'...   Generell gilt:
'...     alle Start-Parameter mit Leerzeichen kapseln -> "mit Leerzeichen"
'...     Start-Parameter überschreiben die In der Konfiguration angegebenen Parameter  
'...     alle Parameter sind Optional
'...
'... Bezugsquellen:
'... WinRar http://www.winrar.de/
'... RAR engl.für DOS 3.60
'... http://suche.softwareload.de/fast-cgi/tsc?context=sl&mandant=toi&device=html&q=rar  
'...............................................................................................

Dim sourceFolders, destination, excludeFiles, password, rarProg, fileSize, sN, includeFileType
Dim oArgs, rarStages, backupTyp, fileFormat, siDate, Extract, sfx, noListing, recover
Dim fso, wsh, lw, s, sEx, sTmp, sDate, separateDrive, sSF, i, j

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

' Quellverzeichnisse
' Wichtig: Geben Sie bei den Quellpfaden keinen abschließenden Backslash an
' -------------------------------------------------------------------------
sourceFolders = Array("c:\tmp", "d:\tmp")

' Ausschlussdateien
' ------------------
' XP: Wenn Dokumente und Einstellungen gesichert werden soll
'excludeFiles = Array("NetworkService", "Default User", "LocalService", "Thumbs.db", "Cookies", "Druckumgebung", "IECompatCache", "IETldCache", "Netzwerkumgebung", "Recent", "SendTo", "Startmenü", "Temporary Internet Files", "Cache", "parent.lock", "Temp*", "*.tmp", "Thumbs.db", "*.lnk")
excludeFiles = Array("Cache", "parent.lock", "Temp*", "*.tmp", "Thumbs.db")

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

' Das Zielverzeichnis
' -------------------
destination = "d:\back up\sicherung"

' Archiv-Foramt
' -> "rar" oder "zip" (zip nur wenn WinnRAR vorhanden ist !)
' Hier gibt es noch Probleme bei ZIP wenn z.B Quelle mehr als 2 Ordner sind
' ----------------------------------------------------------
fileFormat = "rar"

' Passwort angeben
' -> "?" -> öffnet ein Eingabefenster
' -----------------------------------
password = ""

' Blick ins Archiv verwehren (Dateiliste)
' -> False oder True - Explorer kann nicht hineinschauen (Sowieso nur bei *.zip)
' ---------------------------------------
noListing = False

' Jedes LW In eingenen Pfaden sichern
' False oder True (nur wenn Anzahl sourceFolders > 1 und mehrere LW gesichert werden sollen)
'-------------------------------------------------------------------------------------------
separateDrive = True

' maximale Datei-Größe (In MB)
' -> "" 0 nicht splitten
' -> 50 100 200 500 1000 2000
' ---------------------------
fileSize = 0

' Anzahl Backups
'    1  -> Rar wird ohne Datum im Namen gesichert
' >= 2  -> Rar wird Datum im Namen gesichert 2009-10-30_full.rar
' --------------------------------------------------------------
rarStages = 1

' Backup Typ
' -> "f" => full (Es wird immer komplett gesichert. Viel Speicher wird benötigt)
' -> "i" => incremental (Nur Veränderungen sichern. Alle rarStages wird wieder ein Vollbackup angelegt)
'------------------------------------------------------------------------------------------------------
backupTyp = "i"

' Selbstentpackendes Archiv erzeugen
' -> False oder True (exe wird erzeugt. Rar wird nicht mehr benötigt zu eintpacken des Archivs)
' ---------------------------------------------------------------------------------------------
sfx = False

' Dateiname setzt sich aus dem aktuellen Datum und der Konstanten zusammen
' cFull für Vollbackup und cIncr für das inkrementelle Backup
' cFull sollte ungleich cIncr sein. Sind beide gleich wird immer ein Vollbackup erstellt
' --------------------------------------------------------------------------------------
Const cFull = "_full"
Const cIncr = ""

' Rar-Archiv Wiederherstellungs-Informationen mit einpacken
' "" (nicht), True (1%), x%, 500(Sectoren)  
'-----------------------------------------
recover = ""

'Extrahieren
' -> True oder False
'--------------
Extract = False

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

Const cSpace = " "
Const cBSlash = "\"
Const cSlash = "/"
Const cDQ = """"

Set fso = CreateObject("Scripting.FileSystemObject")
Set wsh = CreateObject("WScript.Shell")
Set oArgs = WScript.Arguments

' Startparameter verarbeiten
openArgs()

' Rarpfad ermitteln
If getWinRarProg() And LCase(fileFormat) = "zip" Then

fileFormat = " -afzip"

Else

fileFormat = vbNullString

End If


' Prüfen ob das Ziel-Laufwerk vorhanden ist.
lw = UCase(Left(destination, 1))
If Not fso.DriveExists(lw & ":" ) Then

wsh.PopUp "Laufwerk '" & lw & ":' nicht vorhanden !", 60 ', "",vbOK + vbError

WScript.Quit

ElseIf Not fso.folderexists(destination) Then

sTmp = "%COMSPEC% /C md " & enclose(destination)

wsh.run sTmp

If Not fso.folderexists(destination) Then

wsh.PopUp "Der ZielPfad '" & destination & "' konnte nicht angelegt werden", 10 , _

"RAR-Script-Fehler", vbOK + vbError

WScript.Quit

End If

End If

destination = Replace(destination, cSlash, cBSlash) 'Evtl. Slashes In Backslashes wandlen

If password = "?" Then password = InputBox("Passwort eingeben" & VbCrLf & "Wird nicht verschlüsselt angezeigt", "Passwort-Abfrage")
If password <> vbNullString Then

password = enclose(password)

If noListing Then

password = " -hp" & password

Else

password = " -p" & password

End If

End If

If fileSize <> vbNullString And CStr(fileSize) <> "0" Then

fileSize = " -vn -v" & fileSize * 1024 & cSpace

Else

fileSize = vbNullString

End If

If rarStages = 0 Then rarStages = 1

i = UBound(includeFileType)
If i = 1 Then

If includeFileType(0) = vbNullString Or includeFileType(0) = "*" Then

sN = vbNullString

Else

sN = " -n" & includeFileType(0)

End If

ElseIf i > 1 Then

sN = " -n" & Join(includeFileType, " -n")

End If

i = UBound(excludeFiles)
If i > 0 Then

excludeFiles = enclose(excludeFiles)

sEx = " -x" & Join(excludeFiles, " -x")

End If

'Leerzeichen kaplseln
sourceFolders = enclose(sourceFolders)

If sfx Then

Const cD = "Default.SFX" 'Grafische Entpackoberfläche

  'Const cW = "WinCon.SFX"  'Dos

sTmp = GetPath_From_FilePath(rarProg) & cD

If Not fso.FileExists(sTmp) Then

i = wsh.PopUp("Die Datei '" & s & "' im RAR-Packerpfad " & vbcrlF & sTmp  & vbcrlF & _

"wurde nicht gefunden." & vbcrlF & "Normales Archiv erzeugen." , 10 , _

"Selbstenpakendes Archiv *.exe", vbYesNo + vbQuestion)

If i = vbYes Then

Else

WScript.Quit

End If

sfx = vbNullString

Else

sfx = " -sfx" & enclose(sTmp)

End If

Else

sfx = vbNullString

End If

If recover = True Or LCase(recover) = "True" Then

recover = " -rr"

ElseIf InStr(1, recover, "%") Or IsNumeric(recover) Then

recover = " -rr" & Replace(recover, cSpace, vbNullString)

Else

recover = vbNullString

End If

sDate = Year(Now) & "-" & addLeadingZero(Month(Now)) & "-" & addLeadingZero(Day(Now))


If separateDrive Then sSF = " -ep3"
If Extract Then

wsh.CurrentDirectory = destination 'Ordner zum Entpacken festlegen

For i = 0 To UBound(sourceFolders)

s = rarProg & " x " & password & sourceFolders(i)

  '--- Folgende Zeile muss für den produktiven Betrieb auskommentiert werden. Nur für Test ---  
    's = InputBox ("Startaufruf um Rar zu starten", "Nur zur Info / Test", s)

wsh.Run s, 1, True  

Next

s = Join(sourceFolders, vbCrLF)

wsh.popup "Archiv(e) '" & s & "' wurde nach " & destination & " entpackt.", 6,  "Fertig"

WScript.Quit

ElseIf fileRotate = True Or LCase(backupTyp) = "f" Then

destination = enclose(destination & cBSlash & sDate & cFull)

  ' u           Dateien ins Archiv pachen (updaten)
  '-y          sag ja zu allem
  '-m4          Kompressionrate (0-nicht komprimieren...3-default...5-maximal)
  '-ms          keine Komprimiertung für 7z, ace, arj, bz2, cab, gz, jpeg, jpg, lha, lzh, mp3, rar, taz, tgz, z, zip
  '-ri1         Programm-Priorität setzen (0-default, 1-min..15-max) und Pausenzeit

s = rarProg & " u -r -y -ri1 -ms" & sN & sSF & password & fileFormat & fileSize & sfx & sN & sEx & _

recover & cSpace & destination & cSpace & Join(sourceFolders, cSpace)

  '--- Folgende Zeile muss für den produktiven Betrieb auskommentiert werden. Nur für Test ---  
  's = InputBox ("RAR", "Nur zur Info / Test", s)

wsh.Run s, 1, True

wsh.popup "RAR-Datei '" & destination & "' wurde erstellt.", 6,  "Fertig"

Else

Const XCOPYPARAMETER = " /S /C /I /Q /G /H /R /K /O /Y"

If LCase(cFull) = LCase(cIncr) Then

If cFull = vbNullString Then

cFull = "_full"

Else

cIncr = vbNullString

End If

End If

s = CStr(FormatDateTime (siDate, 2)) '#11/31/2009 07:15:56 AM#  -> 31.11.2009 Deutsch !!

siDate = Mid(s, 4, 2) & "-" & Left(s, 2) & "-" & Right(s, 2)

sTmp = wsh.ExpandEnvironmentStrings("%temp%") & cBSlash & fso.GetTempName

For i = 0 To UBound(sourceFolders)

If separateDrive Then

sSF = cBSlash & Left(sourceFolders(i), 1) & "_"  

Else

sSF = vbNullString

End If

s = "xcopy " & enclose(sourceFolders(i)) & cSpace & enclose(sTmp & sSF & Right(sourceFolders(i), Len(sourceFolders(i)) - 2)) & _

XCOPYPARAMETER & " /D:" & siDate

    '--- Folgende Zeile muss für den produktiven Betrieb auskommentiert werden. Nur für Test ---  
    's = InputBox ("XCOPY", "Nur zur Info / Test", s)

wsh.Run s, 0, True

Next

If fso.folderexists(sTmp) Then

destination = enclose( destination & cBSlash & sDate & cIncr)

WScript.sleep 500

    '-ep1    Pfad bis zum sourceFolder abschneiden

s = rarProg & " u -r -y -ri1 -ms -ep1" & password & fileFormat & fileSize & sfx & sN & sEx & recover & cSpace & destination &  cSpace & sTmp & "\*"

    '--- Folgende Zeile muss für den produktiven Betrieb auskommentiert werden. Nur für Test ---  
    's = InputBox ("Startaufruf um Rar zu starten", "Nur zur Info / Test", s)

wsh.Run s, 0, True

s = "%COMSPEC% /C rd /s /q " & sTmp

wsh.Run  s, 0, True

wsh.popup "RAR-Datei '" & destination & "' wurde erstellt.", 6,  "Fertig"

Else

wsh.popup "Keine Dateien zum Updaten gefunden.", 6,  "Fertig"

End If

End If

'---------------------------------------------------------------------------------------
'--- Funktionen ------------------------------------------------------------------------
'---------------------------------------------------------------------------------------

Function addLeadingZero(number)

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

addLeadingZero = number

End Function

Function getWinRarProg()
' rar In allen möglichen Pfaden suchen

Dim cR

cR = Array("winrar.exe", "rar.exe", "rar32.exe")

For i = 0 To 2

    ' rarProg = "PFAD_ZUR_WINRAR.EXE" 'eintragen falls sie nicht gefunden wird

rarProg = wsh.ExpandEnvironmentStrings("%ProgramFiles%") & "\winrar\" & cR(i) 'c:\Programme\WinRar\

If Not fso.FileExists(rarProg) Then

rarProg = wsh.ExpandEnvironmentStrings("%SystemDrive%") & "\winrar\" & cR(i)'c:\WinRar\

If Not fso.fileexists(rarProg) Then

rarProg = Replace(WScript.ScriptFullName ,WScript.ScriptName, vbNullString) & cR(i) 'Scriptpfad

If Not fso.FileExists(rarProg) Then

rarProg = Replace(WScript.ScriptFullName ,WScript.ScriptName, vbNullString) & "\winrar\" & cR(i) 'Scriptpfad\winrar

If Not fso.FileExists(rarProg) Then

rarProg = wsh.ExpandEnvironmentStrings("%ProgramFiles%") & "\rar\" & cR(i) 'c:\Programme\rar\

If Not fso.FileExists(rarProg) Then

rarProg = wsh.ExpandEnvironmentStrings("%SystemDrive%") & "\rar\" & cR(i) 'c:\rar\

If Not fso.FileExists(rarProg) Then

rarProg = Replace(WScript.ScriptFullName ,WScript.ScriptName, vbNullString)  & "\rar\" & cR(i) 'Scriptpfad\rar

If Not fso.FileExists(rarProg) Then

Else : Exit For

End If

Else: Exit For

End If

Else: Exit For

End If

Else: Exit For

End If

Else : Exit For

End If

Else: Exit For

End If

Else: Exit For

End If

Next

If i = 0 Then    

getWinRarProg = True 'WinRAR

Else

getWinRarProg = False

End If

rarProg = enclose(rarProg)
End Function

Function fileRotate()

Dim rs, desFolder, fNew

On Error Resume Next

Set desFolder = fso.GetFolder(destination)

If Err.Number <> 0 Then

fso.createfolder(destination)

Err.Clear

Set desFolder = fso.GetFolder(destination)

End If

On Error Goto 0

fNew = True

i = 0

Set rs = BackupFolderRecordSet(desFolder)

If Not (rs.Eof) Then

fNew = True

rs.Sort = "date DESC"  

rs.MoveFirst

If FormatDateTime(rs.fields("date"), 2) = FormatDateTime(Now, 2) And fileSize <> vbNullString Then

     ' heute wurde schon mal eine Rar erstellt und die Archive werden gesplittet. Gesplittete Archive können nicht upgedatet werden!

s  = enclose(rs.fields("name"))

s = "%COMSPEC% /C del /F /Q " & Left(s, Len(s) - 4) & "*"

wsh.Run s, 0, True

rs.Close

Set rs = BackupFolderRecordSet(desFolder)

If rs.RecordCount = 0 Then

Exit Function

Else

rs.Sort = "date DESC"  

rs.MoveFirst

End If

End If

siDate = rs.fields("date")

Do Until rs.Eof

If i >= rarStages Then

       'Set sPath = fso.getdestination

s = "%COMSPEC% /C del /F /Q " & enclose(rs.fields("name"))

wsh.Run s, 0, True

WScript.sleep 500

Else

If InStr(1, rs.fields("name"), cFull) Then fNew = False

End If

i = i + 1

rs.MoveNext

Loop

Else

'   fNew = False

End If

fileRotate = fNew

End Function

Function BackupFolderRecordSet(folder)

Dim aFiles

' Konstanten für ADO

Const adVarChar = 200

Const adDate = 7

' Feldnamen fürs RecordSet

Dim rsFieldNames

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

Set BackupFolderRecordSet = CreateObject("ADODB.RecordSet")

With BackupFolderRecordSet

.Fields.Append "name", adVarChar, 255

.Fields.Append "date", adDate

.Open

For Each aFiles In folder.Files

If Left(aFiles.Name, 2) = "20" And (Right(aFiles.Name, 4) = ".rar" Or Right(aFiles.Name, 4) = ".zip") Then ' nur die Datumsordner In die Liste aufnehmen

.addnew rsFieldNames, Array(aFiles.Path, aFiles.DateCreated)

End If

Next

End With

End Function

Function GetPath_From_FilePath(sFilePath)

sFilePath = Replace(sFilePath, cSlash , cBSlash)

GetPath_From_FilePath = Left(sFilePath,  InStrRev(sFilePath, cBSlash))

If Left(GetPath_From_FilePath, 1) = cDQ Then GetPath_From_FilePath = Right(GetPath_From_FilePath, Len(GetPath_From_FilePath)- 1 )

End Function

Function openArgs()

Dim sOA, s, s2, n, x

Dim fDestination

fDestination = False

j = 0

x = 0

n = 0

If oArgs.Count = 0 Then

    'Abfangen wenn kein Argument übergeben wurde

Else

For i = 0 To oArgs.Count - 1

On Error Resume Next

sOA =LCase(oArgs(i))

If sOA = "x" Or sOA = "e" Then       'ohne führendes Minuszeichen

Extract = True                     'Entpacken

ElseIf sOA = "-sfx" Then

sfx = True                         'Selbstentpackendes Archiv

ElseIf sOA = "-ep3" Then

separateDrive = True

ElseIf sOA = "-afzip" Then

fileFormat = "ZIP"                            

ElseIf Left(sOA, 1) = "-" Then       'Parameter

s = Left(sOA, 2)

s2 = Right(sOA,Len(sOA) -2)

Select Case s

Case "-a": rarStages = s2        'Anzahl der Kopien

Case "-b": backupTyp = s2        'Backupart f

Case "-v": fileSize  = s2        'Dateigröße nachdem gesplittet wird  

Case "-p": password  = s2        'Passwort

Case "-n"                         'Dateien/Ordner einschließen

ReDim Preserve includeFileType(n)

includeFileType(n) = sOA

n = UBound(includeFileType) + 1      

Case "-x"                         'Dateien/Ordner ausschließen

ReDim Preserve excludeFiles(x)

excludeFiles(x) = sOA

x = UBound(excludeFiles) + 1      

Case "-f":                       'Packformat  

If s2 = "z" Then

fileFormat = "ZIP"                        

Else

fileFormat = "RAR"

End If

Case Else

s = LCase(Left(sOA, 3))

If s = "-hp" Then

password  = s2

noListing = True

ElseIf s = "-rr" Then

rerecover = sOA

End If  

End Select

Else

If Not fDestination Then           'Ziel-Datei

destination = sOA

fDestination = True

Else                               'Quellen

If Extract Then

If Not (Right(sOA, 4) = ".rar" Or Right(sOA, 4) = ".zip") Then

wsh.PopUp "Als letzte Parameter müssen Rar oder Zip Archive angegeben werden !", 15

WScript.Quit

End If

Else

ReDim Preserve sourceFolders(j)

sourceFolders(j) = sOA

j = UBound(sourceFolders) + 1    

End If

End If

End If        

On Error Goto 0

Next

End If  

End Function

Function enclose(v)

Dim va

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

enclose = va

End Function

'Function SetDrive(LW)
'net use e: \\financial\letters /persistent:no

'net use e: /delete
'End Function

'Function GetFreeDrive(LW)
'Dim i
'for i = 97 To 122
'  s = Chr(i)
'  If Not fso.DriveExists(s & ":") then
'    LW = s
'  End If
'Next
'End Function