'######################################################## '# '# Created Sat 14/07/2012 '# By: Dave Harrison '# For: who ever wants to use it.. '# '# - Backs up data to a new folder '# - deletes old folders that are older then 5 days '# - emails the backup status to user. '######################################################## '-------------------------------------------------------- ' MODIFY THE VARIABLES BELOW '-------------------------------------------------------- ' this is the volume name that is assigned to the USB drive - not the drive letter!. drivename = "DATADRIVE" ' This is where the data is currently stored on the server, that we will be copying. FolderFrom = "C:\raspPi" '-------------------------------------------------------- KeepACopyFor = 5 ' days '-------------------------------------------------------- ' email addresses emlfrom = "intranet@idealheating.com" emlto = "dave_harrison@idealheating.com" smtpserver = "1.52.90.80" smtpuser = "" smtppass = "" smtpSSL = "no" ' or yes '-------------------------------------------------------- ' END MODIFY '-------------------------------------------------------- ' fetch our drive letter for the given volume name. DriverLetter = "" freespace = "" getDriveDetails() if len(DriverLetter) = 0 then ' send email saying drive is missing. failedEmail("the Backup program can't find the backup drive!") WScript.quit end if ' copy the data to backup drive dim FolderTo dim timestamp dim FolderToA timestamp = replace(replace(replace(now()," ",""),":",""),"/","") FolderTo = DriverLetter & "\Archive" FolderToA = FolderTo & "\" & timestamp 'msgbox(folderfrom & vbcrlf & folderToA) CopyData() ' clean up old data older then 5 days. deleteOlddata() ' email results createEmailReport() '#################################################################################### ' DONT MODIFY BELOW THIS LINE '#################################################################################### ' lets look for our USB drive based on volume description. function getDriveDetails() strComputer = "." Set objWMIService = GetObject("winmgmts:" _ & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2") Set colDisks = objWMIService.ExecQuery _ ("Select * from Win32_LogicalDisk Where DriveType = 3") For Each objDisk in colDisks VolName = objdisk.volumename if Volname = drivename then intFreeSpace = round(objDisk.FreeSpace/1048576,2) intTotalSpace = objDisk.Size pctFreeSpace = intFreeSpace / intTotalSpace freespace = pctFreeSpace ' we dont need the above details, but its nice to have. DriverLetter = objdisk.name end if Next End function ' copy our data across. function CopyData() dim filesys set filesys=CreateObject("Scripting.FileSystemObject") If filesys.FolderExists(FolderFrom) Then if filesys.folderExists(FolderToA) then filesys.CopyFolder FolderFrom, FolderToA else 'failedEmail("The Archive folder is missing from the backup Drive!") Set objFolder = filesys.createFolder(FolderToA) filesys.CopyFolder FolderFrom, FolderToA end if else ' folder doesnt exist!!! End If end function ' now delete old data off the drive. function deleteOlddata() Set fso = CreateObject("Scripting.FileSystemObject") Set f = fso.GetFolder(FolderTo) Set sf = f.SubFolders For Each f1 in sf ' n = minutes, h = hours, d = days, m = months CalcResult = DateDiff("n",f1.DateCreated,Now) if CalcResult > KeepACopyFor then ' msgbox(BasePath & "\" & f1.Name) FSO.DeleteFolder(FolderTo & "\" & f1.Name) 'msgbox(calcResult) end if Next end function ' create an email and report the status of the backed up data. function createEmailReport() WriteLine ="" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "Below is the current status of your backup directory:

" WriteLine = WriteLine & "" WriteLine = WriteLine & "" ' get the status of data in the backup directory. Set fso = CreateObject("Scripting.FileSystemObject") Set f = fso.GetFolder(FolderTo) Set sf = f.SubFolders For Each f1 in sf fname = f1.Name fsize = f1.size ' fcount = f1.files.count Ffcount = f1.subfolders.count fcount = CountFiles(f1) WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" 'WriteLine = WriteLine & "" 'WriteLine = WriteLine & "" 'WriteLine = WriteLine & "" 'WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" WriteLine = WriteLine & "" Next WriteLine = WriteLine & "
Directory:" & FolderTo & "
FolderName:" & fname & "
Folder size:" & round(fsize/1048576,2) & " MB
File Count:" & fcount & "
Folder Count:" & ffcount & "

" WriteLine = WriteLine & "
" WriteLine = WriteLine & "
Created by and For David Harrison" WriteLine = WriteLine & "
" WriteLine = WriteLine & "" set msg = CreateObject("CDO.Message") msg.From = emlfrom msg.To = emlto msg.Subject = "Intranet SAMPLE - for " & date() msg.HTMLBody = WriteLine msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtpserver msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 if lcase(smtpSSL) = "yes" then msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = true end if if len(smtpuser) > 0 then msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = smtpuser msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = smtppass end if msg.Configuration.Fields.Update msg.Send set msg = nothing end function Function CountFiles (ByVal StrFolder) Dim ParentFld Dim SubFld Dim IntCount set fs=CreateObject("Scripting.FileSystemObject") Set ParentFld = fs.GetFolder (StrFolder) ' count the number of files in the current directory IntCount = ParentFld.Files.Count For Each SubFld In ParentFld.SubFolders ' count all files in each subfolder IntCount = IntCount + CountFiles(SubFld.Path) Next CountFiles = IntCount End Function function failedEmail(thisval) thisvalA = "" thisvalA = thisvalA & "Your backup failed because..." thisvalA = thisvalA & "

" thisvalA = thisvalA & thisval thisvalA = thisvalA & "" set msg = CreateObject("CDO.Message") msg.From = emlfrom msg.To = emlto msg.Subject = "Backup failure! " & date() msg.HTMLBody = thisvalA msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtpserver msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 REM msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 REM msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = true REM 'msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "*****" REM 'msg.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "*****" msg.Configuration.Fields.Update msg.Send set msg = nothing end function