RAR Archiv Packen / Entpacken

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