Option Explicit

'...............................................................................................
'... 7z.vbs 1.03   Autor: Michael Hölldobler hoelldobler[at]alant.de
'... Script benötigt eine Version des 7z-Packers
'... Packen:    7z.vbs -<Parameter1> -<Parameter2> -<..>. Archiv-Pfad <Quelle1> <Quelle2> <..>
'... Entpacken: 7z.vbs x <-p> Entpack-Ziel-Pfad Archiv.7z
'... Parameter:
'...   -pPasswort                                           (Optional)
'...   -mhe     (Ordnerstruktur verbergen bei Passwort)     (Optional)
'...   -bi      für incremental -bf für full (default)      (Optional)
'...   -t7z     Fileformat 7z(default) -tz ZIP              (Optional)
'...   -a1      Anzahl Datei-Versionen 1(default)           (Optional)
'...   -d0      nicht -d1 LW In eingenen Pfaden speichern   (Optional)
'...   -v100m   maximale Dateigröße danach wird gesplittet  (Optional)
'...   -sfx     Selbstentpackendes Archiv.exe erzeugen      (Optional)
'...   -i<file> nur diese Dateien einschließen  z.B -i*.doc (Optional)
'...   -x<file> Diese Datei ausschließen (mehrfach möglich -x*.tmp -x*.mp3) (Optional)
'...
'...   Generell gilt alle Parameter mit Leerzeichen kapseln -> "mit Leerzeichen"
'...   Optionale Parameter werden wie unten im Konfigurations-Teil verwendet, wenn nichts angegeben
'... Bezugsquellen:
'... http://www.7zip.org/
'... Windows Server 2003 Resource Kit Tools (enthält LinkD.exe)
'... http://search.microsoft.com/results.aspx?mkt=de-DE&q=Windows+Server+2003+Resource+Kit+Tools
'...............................................................................................

Dim sourceFolders, destination, excludeFiles, includeFileType, password, sevenZipProg, fileSize
Dim oArgs, sevenZipStages, backupTyp, fileFormat, siDate, Extract, sfx, noListing
Dim fso, wsh, lw, s, s2, s3, sEx, stmp, sDate, separateDrive, LinkDProg, sRLD, i, j

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

'ftp://ftp.info-zip.org/pub/infozip/win32/zip300xn.zip -> Datei zip.exe entpacken !

'-slp Large Pages mode increases the speed of compression only recommendee If more than 100 MB To compress

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


' Ausschlussdateien
' ------------------
excludeFiles = Array("Cache")
'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
' -------------
' -> "7z" oder "zip"
fileFormat = "7z"

' Passwort angeben
' -> "?" -> öffnet ein Eingabefenster
' -----------------------------------
password = ""'"0815 ist als Passwort nicht OK"

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

' LW In eingenen Pfaden speichern
' Hierfür LinkD benötigt
' False oder True (nur wenn Anzahl sourceFolders > 1 und mehrere LW gesichert werden sollen)
' -------------------------------
separateDrive = False

' maximale Datei-Größe
' -> "" 100k (Kilobyte) 100m (Megabyte) 2g (Gigabytes)
' --------------------
fileSize = ""

' Anzahl Backups
' --------------
'    1  -> 7z wird ohne Datum im Namen gesichert
' >= 2  -> 7z wird Datum im Namen gesichert 2009-10-30_full.7z
sevenZipStages = 7

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

' Selbstentpackendes Archiv erzeugen
' -> False oder True (exe wird erzeugt. 7zip 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
' ------------------------------------------------------------------------

Const cFull = "_full"
Const cIncr = ""

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

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

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

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

' 7z-Pfad ermitteln
getSevenZipProg()

' Startparameter verarbeiten
openArgs()

If LCase(fileFormat) = "zip" Then

fileFormat = " -tzip"

Else

fileFormat = " -t7z"

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

fso.createfolder destination

End If

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 = "-mhe=on -p" & password

Else

password = " -p" & password

End If

End If

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

If IsNumeric(fileSize) Then fileSize = fileSize & "m"

fileSize = " -v" & fileSize

Else

fileSize = vbNullString

End If

If UBound(excludeFiles) > 0 Then

excludeFiles = enclose(excludeFiles)

sEx = " -xr!" & Join(excludeFiles, " -xr!") & cSpace

End If

' Laufwerke Separieren
If UBound(sourceFolders) < 1 Then separateDrive = False

If sfx Then

Const cD = "7z.sfx"     'Grafische Entpackoberfläche

'Const cW = "7zCon.sfx" 'Dos
'Const cW = "7zS.sfx"   'Windows version for installers.
'Const cW = "7zSD.sfx"  'Windows version for installers (uses MSVCRT.dll)

stmp = GetPath_From_FilePath(sevenZipProg) & cD

If Not fso.FileExists(stmp) Then

i = wsh.PopUp("Die Datei '" & s & "' im 7zip-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)

fileSize = vbNullString

End If

Else

sfx = vbNullString

End If

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

If Extract Then

wsh.CurrentDirectory = destination 'Ordner zum Entpacken festlegen

For i = 0 To UBound(sourceFolders)

s = sevenZipProg & " x " & password & enclose(sourceFolders(i))

'--- Folgende Zeile muss für den produktiven Betrieb auskommentiert werden. Nur für Test ---

s = InputBox ("7zip", "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

Dim sTP, sB, sSF, sLDF

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

'If separateDrive Then

If getLinkD() Then 'Junction erzeugen. LinkD muss vorhanden sein

On Error Resume Next

sTP = wsh.ExpandEnvironmentStrings("%SystemDrive%") & cBSlash & fso.GetTempName

For i = 0 To UBound(sourceFolders)

j = InStrRev(sourceFolders(i), cBSlash)

lw = Left(sourceFolders(i), 1) & "_"

If j = 0 Then 'c: Nur LW

s = IIf(separateDrive, cBSlash & lw, vbNullString)

s2 = sTP  & s

stmp = "%COMSPEC% /C md " & sTP

wsh.run stmp, 0, True

s3 = vbNullString

sLDF = s3

sSF = sourceFolders(i) & cBSlash

Else

Stop

s = IIf(separateDrive,  cBSlash & Replace(Left(sourceFolders(i), j),  ":" , "_"), Mid(sourceFolders(i), 3, j - 3))

sB = sTP & s

stmp = "%COMSPEC% /C md " & enclose(sB)

'LinkD kann nicht über mehrere Ordner hinweg erzeugt werden. Basisordner muss vorhanden sein.

Stop

wsh.run stmp, 0, True

'LinkD kann mit Umlauten und ß nicht umgehen deshalb alles anpassen
'BasisPfad bis zum LinkD

s2 = IIf(ChrAnsi(sB), getShortPath(sB), sB) '& cBSlash

'LinkD Ordner

sLDF =  Right(sourceFolders(i), Len(sourceFolders(i)) - j)

s3 = IIf(ChrAnsi(sLDF), fso.GetTempName, sLDF)

'Original-Ordner

sSF = IIf(ChrAnsi(sourceFolders(i)), getShortPath(sourceFolders(i)), enclose(sourceFolders(i)))

End If

If fso.FolderExists(s2 & cBSlash & s3) Then

s3 = lw & s3

sLDF = s3

End If

s = LinkDProg & enclose(s2 & cBSlash & s3) & cSpace & sSF

WScript.Sleep 1000

Stop

wsh.run s, 0, True

If s3 <> sLDF Then

stmp = "%COMSPEC% /C ren " & enclose(s2 & cSpace & sSF)

wsh.run stmp, 0, True

End If

Next

Stop

sourceFolders = Array(sTP) '& "\*"

Else

wsh.PopUp "LinkD.exe wird benötigt um Junctions zu erzeugen. Nur dann können die LW In eingenen Pfaden gespeichert werden", 10, "Vorgabe-Fehler", vbOK

End If

'End If
' u           Dateien ins Archiv pachen (updaten)
'-y          sag ja zu allem
'-mx5          Kompressionrate (0-nicht komprimieren...5-default...9-maximal)
'-ssw         auch geöffnete Dateien kopieren (wenn möglich)

'sourceFolders = enclose(sourceFolders)

includeSource()

s = sevenZipProg & " u -y" & password & fileFormat & fileSize & sfx & cSpace & destination & cSpace & Join(sourceFolders, cSpace) & sEx

'--- Folgende Zeile muss für den produktiven Betrieb auskommentiert werden. Nur für Test ---

s = InputBox ("7zip", "Nur zur Info / Test", s)

wsh.Run s, 1, True

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

wsh.Run s, 0, True

Else

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

If LCase(cFull) = LCase(cIncr) Then

cFull = IIf(cFull = vbNullString, "_full", vbNullString)

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)

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

For i = 0 To UBound(sourceFolders)

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

Stop

s = "xcopy " & enclose(sourceFolders(i)) & cSpace & enclose(sTP & 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

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

WScript.sleep 500

sourceFolders = Array(stmp)

s = sevenZipProg & " u -y" & password & fileFormat & fileSize & sfx  & cSpace & destination & cSpace & Join(sourceFolders, cSpace) & sEx

'--- Folgende Zeile muss für den produktiven Betrieb auskommentiert werden. Nur für Test ---

s = InputBox ("7zip", "Nur zur Info / Test", s)

wsh.Run s, 0, True

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

wsh.Run s, 0, True

End If

wsh.popup "7zip hat die Datei nach " & vbCrLf & destination  & vbCrLf & "gepackt.", 6,  "Fertig"

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

Function addLeadingZero(number)

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

addLeadingZero = number

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

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 7z 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 >= sevenZipStages Then

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")

BackupFolderRecordSet.Fields.Append "name", adVarChar, 255

BackupFolderRecordSet.Fields.Append "date", adDate

BackupFolderRecordSet.Open

For Each aFiles In folder.Files

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

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

End If

Next

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, a, b

Dim fDestination

fDestination = False

j = 0

b = 0

a = 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

Extract = True 'Entpacken

ElseIf sOA = "-sfx" Then

sfx = True 'Selbstentpackendes Archiv

ElseIf sOA = "-mhe" Then

noListing = True

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

s = Left(sOA, 2)

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

Select Case s

Case "-a": sevenZipStages = s2        'Anzahl der Kopiene

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

Case "-d":

If s2 = "0" Then

separateDrive = False 'LW im Pfad erzeugen

Else

separateDrive = True 'LW im Pfad erzeugen

End If

Case "-i"                         'Dateien einbeziehen

ReDim Preserve includeFileType(a)

includeFileType(a) = s2

a = UBound(includeFileType) + 1

Case "-p": password  = s2        'Passwort

Case "-t":                       'Packformat

If s2 = "z" Then

fileFormat = "ZIP"

Else

fileFormat = "7z"

End If

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

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

ReDim Preserve excludeFiles(b)

excludeFiles(b) = sOA

b = UBound(excludeFiles) + 1

Case Else

s = Left(sOA, 3)

If s = "-hp" Then

password  = s2

noListing = True

End If

End Select

Else

If Not fDestination Then 'Ziel-Datei

destination = sOA

fDestination = True

Else 'Quellen

If Right(sOA, 4) = ".7z" Or Right(sOA, 4) = ".zip" Then

ReDim Preserve sourceFolders(j)

sourceFolders(j) = sOA

j = UBound(sourceFolders) + 1

Else

wsh.PopUp "Als letzten Parameter muss ein 7z oder Zip Archiv angegeben werden !", 15

WScript.Quit

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 ChrAnsi(v)

Dim a, b

'ASCII ist OK

ChrAnsi = False

For a = 1 To Len(v)

b = asc(Mid(v, a, 1))

If b > 126 Then

ChrAnsi = True 'Ansi-Zeichensatz

Exit For

End If

Next

End Function

Function getShortPath(sPath)

Dim sp

Set sp = fso.GetFolder(sPath)

getShortPath = sp.ShortPath

End Function

Function getSevenZipProg()

Const c7Z = "7z.exe"

' sevenZipProg = "PFAD_ZUR_7z.EXE" 'eintragen falls sie nicht gefunden wird

sevenZipProg = wsh.ExpandEnvironmentStrings("%ProgramFiles%") & "\7-Zip\" & c7Z 'c:\Programme

If Not fso.FileExists(sevenZipProg) Then

sevenZipProg = wsh.ExpandEnvironmentStrings("%SystemDrive%") & "\7-Zip\" & c7Z 'c:\

If Not fso.fileexists(sevenZipProg) Then

sevenZipProg = Replace(WScript.ScriptFullName ,WScript.ScriptName, vbNullString) & c7Z 'Scriptpfad

If Not fso.FileExists(sevenZipProg) Then

sevenZipProg = Replace(WScript.ScriptFullName ,WScript.ScriptName, vbNullString) & "7-Zip\" & c7Z 'Scriptpfad

If Not fso.FileExists(sevenZipProg) Then

wsh.popup  c7Z & " wurde nicht gefunden", 10, , vbExclamation + vbSystemModal

WScript.Quit

End If

End If

End If

End If

sevenZipProg = enclose(sevenZipProg)

End Function

Function getLinkD()

Const cLD = "linkd.exe"

getLinkD = True

LinkDProg = wsh.ExpandEnvironmentStrings("%ProgramFiles%") & "\Windows Resource Kits\Tools\" & cLD 'c:\Programme

If Not fso.FileExists(LinkDProg) Then

LinkDProg = Replace(WScript.ScriptFullName ,WScript.ScriptName, vbNullString) & cLD 'Scriptpfad

If Not fso.fileexists(LinkDProg) Then

LinkDProg = wsh.ExpandEnvironmentStrings("%SystemRoot") & cBSlash & cLD

If Not fso.fileexists(LinkDProg) Then

LinkDProg = wsh.ExpandEnvironmentStrings("%SystemRoot") & "\system32\" & cLD

If Not fso.fileexists(LinkDProg) Then

getLinkD  = False

End If

End If

End If

End If

If InStr(1, LinkDProg, cSpace) > 0 Then LinkDProg = enclose(LinkDProg)

LinkDProg = LinkDProg & cSpace

End Function

Function Iif(v, vTrue, vFalse)
If v Then

IIf = vTrue

Else

IIf = vFalse

End If
End Function

Function includeSource()
Dim a, b, c, arr

If Not IsArray(includeFileType) Then includeFileType = Array("*") ' Sollte oben In der Deklaration das Array gelöscht worden sein.

b = UBound(includeFileType) + 1

Stop

a = UBound(sourceFolders) + 1

ReDim arr((a * b) - 1)

For a = 0 To UBound(sourceFolders)

If Right(sourceFolders(a), 1) <> cBSlash Then sourceFolders(a) = sourceFolders(a) & cBSlash

For b = 0 To UBound(includeFileType)

If includeFileType(b) = vbNullString Then includeFileType(b) = "*"

c = sourceFolders(a) & includeFileType(b)

arr(a + b) = " -ir!" & enclose(c)

Next

Next

sourceFolders = arr

End Function