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