'######################################################## '# '# 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. '######################################################## on error resume next '-------------------------------------------------------- ' 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 = "" '-------------------------------------------------------- KeepACopyFor = 5 ' days '-------------------------------------------------------- ' email addresses emlfrom = "BobJSQL@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 '################################## '# here we run each of our folders runFolder("D:\data") runFolder("D:\VTCT") runFolder("D:\training") runFolder("C:\DirectorsDrive") runFolder("D:\database_Backup") '################################## function runFolder(FF) FolderFrom = FF PFa = replace(FF,"C:\","") PFa = replace(PFa,"D:\","") ' copy the data to backup drive dim FolderTo dim timestamp dim FolderToA timestamp = replace(replace(replace(now()," ","-"),":",""),"/","") FolderTo = DriverLetter & "\Archive" FolderToA = FolderTo & "\" & timestamp & PFa 'msgbox(folderToA) 'msgbox(folderfrom & vbcrlf & folderToA) CopyData(FolderToA) ' clean up old data older then 5 days. deleteOlddata(FolderTo) End function ' email results createEmailReport("F:\Archive") '#################################################################################### ' 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 DriverLetter = objdisk.name end if Next End function ' copy our data across. function CopyData(FolderToA) 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 set filesys = nothing on error goto 0 end function ' now delete old data off the drive. function deleteOlddata(FolderTo) on error resume next 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("d",f1.DateCreated,Now) if CalcResult > KeepACopyFor then ' msgbox(BasePath & "\" & f1.Name) FSO.DeleteFolder(FolderTo & "\" & f1.Name) 'msgbox(calcResult) end if Next set fso = nothing set f = nothing set sf = nothing on error goto 0 end function ' create an email and report the status of the backed up data. function createEmailReport(FolderTo) 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 if f1.DateCreated > cdate(now())-1 then 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 & "" end if 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 = "Hair Rebellion Svr Backup Status - 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 set fso = nothing set f = nothing set sf = nothing set msg = nothing end function Function CountFiles (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