' Backup folder using 7-Zip ' Written by Steve Allison 2014 - steve@allison.im Dim fso, rs, shell ' File System Object Set fso = CreateObject("Scripting.FileSystemObject") ' RecordSet Set rs = CreateObject("Ador.Recordset") ' Shell Set shell = CreateObject("WScript.Shell") Const adVarChar = 200 Const adDate = 7 srcFolder="C:\Customer" dstFolder="S:\Backup" backupName="backup" zipEXE="C:\Program Files\7-Zip\7z.exe" ' Number of files to keep iNum = 5 ' Get the date in the correct order. Why does vbscript suck so hard at date formatting? Function getDateString() d = ZeroPad(Day(Now()), 2) m = ZeroPad(Month(Now()), 2) y = Year(Now()) getDateString = y & m & d End Function ' No printf() in VBScript it seems Function ZeroPad(int, length) If Len(int) < length Then ZeroPad = Right(String(length, "0") & int, length) End If End Function ' Sanity checking If Not fso.FolderExists(srcFolder) Then Wscript.Echo "Aborted. Source folder does not exist: " & srcFolder Wscript.Quit End If If Not fso.FolderExists(dstFolder) Then Wscript.Echo "Aborted. Destination folder does not exist: " & dstFolder Wscript.Quit End If If Not fso.FileExists(zipEXE) Then Wscript.Echo "Aborted. 7-Zip program does not exist: " & zipEXE Wscript.Quit End If ' Create suffix of date-time backupFileDate = getDateString() & "-" & replace(FormatDateTime(now,4),":","") ' File extension backupFileExt = ".7z" ' Backup path without extension backupFilePre = dstFolder & "\" & backupName & "_" & backupFileDate ' Full backup path backupFile = backupFilePre & backupFileExt ' More sanity checking n = 1 Do While fso.FileExists(backupFile) ' Add integeer to file, loop until it doesn't already exist backupFile = backupFilePre & "_" & ZeroPad(n, 2) & backupFileExt n = n + 1 Loop '''' Zip Source Folder ' Create shell command shCommand = """" & zipEXE & """ a -r """ & backupFile & """" ' Change to source directory shell.CurrentDirectory = srcFolder & "/" ' Run 7-Zip in shell shVal = shell.Run(shCommand,4,true) ' Check 7-Zip exit code If shVal > 1 Then Wscript.Echo "7-Zip failed with error code: " & shVal Wscript.Quit End If '''' Remove old backup files ' Add required fields to recordset With rs.Fields .append "filepath", adVarChar, 255 .append "datelastmodified", adDate End With ' Get folder object set rsFolder=fso.getfolder(dstFolder) ' List folder contents to RecordSet With rs .open For Each rsFile in rsFolder.files .addnew array("filepath","datelastmodified"), array(rsFile.path,rsFile.datelastmodified) .update Next End With ' Loop through folder listing recordset i=0 If Not (rs.EOF and rs.BOF) then ' Sort by last modified, newest first rs.Sort = "datelastmodified desc" ' Move recordset pointer to first record rs.MoveFirst ' Loop through recordset Do While Not rs.EOF ' get path from recordset dFile = fso.GetFile(rs.Fields("filepath")) ' get filename from path dFileName = fso.GetFileName(dFile) ' Check if backupName is in the filename if InStr(1, dFileName, backupName, 1) Then i=i+1 ' wait until >iNum matches if i > iNum Then ' Delete file, ignore errors On Error Resume Next fso.DeleteFile rs.Fields("filepath"), true On Error Goto 0 End If End If rs.MoveNext Loop End If Wscript.Echo "Backup complete at " & backupFile