Option Explicit '========================================================================= ' DirMirror.vbs ' VERSION: 1.0 ' AUTHOR: Brian Steinmeyer ' EMAIL: [email protected] ' WEB: https://sigkillit.com ' DATE: 9/26/2013 ' REQUIREMENTS: ' - robocopy.exe (Built in to Server2008+, Windows 7+) ' - blat.exe, blat.dll. blat.lib in the same directory as the script (http://www.blat.net) ' - Blat profile installed to email results ' - Recommended to use Stunnel to Encrypt Email Sessions, Especially If the Email Server ' is not on your subnet ex: Gmail ' COMMENTS: Requires robocopy for the backup and blat to email results. Define ' the Directory Source(what you need to backup), the Directory Destination ' (where you need to backup to), path to blat, blat profile, email subject, ' and email body '========================================================================= ' ------ SCRIPT CONFIGURATION ------ Const WindowStyle = 0 '0=Hide Robocopy Console, 1=Show Robocopy Console Dim DirSource: DirSource = "\\server\share\directory" Dim DirDestination: DirDestination = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\")) & "backup" Dim intReturn 'Generic Return Dim logErrors: logErrors = Replace(WScript.ScriptFullName,".vbs","_log.txt") Dim emailBlatExe: emailBlatExe = "C:\blat\blat.exe" 'Custom Path to Blat.exe Default is Same Folder as Script Dim emailProfile: emailProfile = "gmail" 'Blat Profile Name See (http://www.blat.net) For Info Dim emailRecipient: emailRecipient = "[email protected]" 'Email to Receive Backup Result Dim eSubject: eSubject = "Server1 Backup" Dim eBody: eBody = "Server1 Backup" ' ------ END CONFIGURATION ------ 'MAIN CALLS Call Logger(logErrors, "[" & Now() & "] " & vbCrLf & Wscript.ScriptName & vbCrLf & "Server: Spiceworks", True) Call AllowSingleInstance(".",logErrors, emailBlatExe, emailProfile, emailRecipient, eSubject, eBody) Call ConfirmDirectories(logErrors, DirSource, DirDestination, emailBlatExe, emailProfile, emailRecipient, eSubject, eBody) Call RoboDirMirror(logErrors, DirSource, DirDestination, emailBlatExe, emailProfile, emailRecipient, eSubject, eBody) ' *************************************************************************************************** ' Function RoboDirMirror - Mirrors a Source Directory to a Mirror Directory Using Robocopy ' *************************************************************************************************** Private Sub RoboDirMirror(logName, strSource, strDestination, emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody) 'On Error Resume Next Call Logger(logName, vbCrLf & "[" & Now() & "] " & vbCrLf & "Run Robocopy to Mirror Directory", False) 'Ensure Directories Don't End with Slash or Robocopy Will Error If Mid(strSource,Len(strSource),1) = "\" Then strSource = Mid(strSource,1,Len(strSource) - 1) End If If Mid(strDestination,Len(strDestination),1) = "\" Then strDestination = Mid(strDestination,1,Len(strDestination) - 1) End If Dim objShell: Set objShell = WScript.CreateObject("WScript.Shell") Dim strCommand: strCommand = "robocopy" Dim cmdOptions: cmdOptions = "/MIR /FFT /Z /XA:H /W:5 /log+:" & chr(34) & logName & chr(34) 'Robocopy \\SourceServer\Share \\DestinationServer\Share /MIR /FFT /Z /XA:H /W:5 Dim intReturn: intReturn = objShell.Run(strCommand & " " & chr(34) & strSource & chr(34) & " " & chr(34) & strDestination & chr(34) & " " & cmdOptions, WindowStyle, True) Select Case intReturn Case 0 'No Files Copied Call Logger(logName, "RESULT: Success - No Files Copied", False) emailSubject = emailSubject & " Success" emailBody = emailBody & " Success - No Files Copied" Case 1 'Files Copied Call Logger(logName, "RESULT: Success - Files Copied", False) emailSubject = emailSubject & " Success" emailBody = emailBody & " Success - Files Copied" Case 2 'File on Source Does Not Exist on Destination Call Logger(logName, "RESULT: Success - New Files Found in Source that are Not in Destination", False) emailSubject = emailSubject & " Success" emailBody = emailBody & " Success - New Files Found in Source that are Not in Destination" Case 3 'Combination of Case1 and Case2 Call Logger(logName, "RESULT: Success - Files Copied (New Files Found in Source that are Not in Destination)", False) emailSubject = emailSubject & " Success" emailBody = emailBody & " Success - Files Copied (New Files Found in Source that are Not in Destination)" Case Else 'Error Call Logger(logName, "RESULT: !~ERROR~! - Error Occurred on Robocopy", False) emailSubject = emailSubject & " FAILED" emailBody = emailBody & " FAILED - Error Occurred on Robocopy" End Select If Err.Number <> 0 Then Err.Clear Call Logger(logName, "!~ERROR~! - Unknown Error Occurred in RoboDirMirror Sub", False) emailSubject = emailSubject & " FAILED" emailBody = emailBody & " FAILED - Unknown Error Occurred in RoboDirMirror Sub" End If Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName) End Sub ' *************************************************************************************************** ' Function ConfirmDirectories - Confirm Source and Destination Directories Exist ' *************************************************************************************************** Private Sub ConfirmDirectories(logName, strSource, strDestination, emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody) 'On Error Resume Next Call Logger(logName, vbCrLf & "[" & Now() & "] " & vbCrLf & "Confirm Source/Destination Directories Exist", False) ' Create Objects Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject") Call Logger(logName, "SOURCE: " & strSource, False) Call Logger(logName, "DESTINATION: " & strDestination, False) If Not objFSO.FolderExists(strSource) Then 'Source Not Exist Call Logger(logName, "!~ERROR~! - Source Directory Does Not Exist, Quitting Script!", False) emailSubject = emailSubject & " FAILED" emailBody = emailBody & " Failed - Source Directory Does Not Exist" Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName) Wscript.Quit Else Call Logger(logName, "Success - Source Directory Exists", False) End If If Not objFSO.FolderExists(strDestination) Then 'Destination Not Exist Call Logger(logName, "Warning - Destination Directory Does Not Exist, Attempting to Create It", False) 'Attempt to Create Call CreateFileOrDir(strDestination) If Not objFSO.FolderExists(strDestination) Then Call Logger(logName, "!~ERROR~! - Failed to Create Destination Directory, Quitting Script!", False) emailSubject = emailSubject & " FAILED" emailBody = emailBody & " Failed - Destination Directory Does Not Exist and Failed to Create It" Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName) Wscript.Quit Else Call Logger(logName, "Success - Created Destination Directory", False) End If Else Call Logger(logName, "Success - Destination Directory Exists", False) End If If Err.Number <> 0 Then Err.Clear Call Logger(logName, "!~ERROR~! - Unknown Error in ConfirmDirectories Sub, Quitting Script", False) emailSubject = emailSubject & " FAILED" emailBody = emailBody & " Failed - Unknown Error in ConfirmDirectories Sub" Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName) Wscript.Quit End If End Sub ' *************************************************************************************************** ' Function AllowSingleInstance - Checks if only a single instance of the script is running - useful ' for repetitive scheduled tasks ' *************************************************************************************************** Private Sub AllowSingleInstance(strComputer, logName, emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody) On Error Resume Next Call Logger(logName, vbCrLf & "[" & Now() & "] " & vbCrLf & "Confirm Single Instance of " & Wscript.ScriptName, False) Dim intReturn: intReturn = 0 '0=Success, 1=Error, 2=Warning Dim objWMIService: Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2") Dim colItems: Set colItems = objWMIService.ExecQuery("Select * from Win32_Process Where Name = 'cscript.exe'" & " OR Name = 'wscript.exe'") Dim intCount: intCount = 0 Dim objItem, strTemp For Each objItem in colItems If Not IsNull(objItem.CommandLine) Then strTemp = Right(objItem.CommandLine, Len(objItem.CommandLine) - InStrRev(objItem.CommandLine, chr(34) & " " & chr(34))) strTemp = Trim(Replace(strTemp, chr(34), "")) If StrComp(Wscript.ScriptFullName, strTemp, 1) = 0 Then intCount = intCount + 1 End If End If Next Call Logger(logName, "Detected Instances: " & intCount, False) If intCount > 1 Then 'Kill It Call Logger(logName, "!~ERROR~! - Only 1 instance is allowed, Quitting Script!", False) emailSubject = emailSubject & " FAILED" emailBody = emailBody & " Backup FAILED - Detected " & intCount & " running instances" Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName) Wscript.Quit End If If Err.Number <> 0 Then Err.Clear Call Logger(logName, "!~ERROR~! - Unknown Error in AllowSingleInstance Sub, Quitting Script!", False) emailSubject = emailSubject & " FAILED" emailBody = emailBody & " Backup FAILED - Unknown Error in AllowSingleInstance Sub" Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName) Wscript.Quit End If On Error Goto 0 End Sub ' *************************************************************************************************** ' Function CreateFileOrDir ' *************************************************************************************************** Private Sub CreateFileOrDir(strPath) On Error Resume Next Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject") If objFSO.DriveExists(objFSO.GetDriveName(strPath)) Then If StrComp(objFSO.GetExtensionName(strPath), "", 1) = 0 Then If Not objFSO.FolderExists(strPath) Then If objFSO.FolderExists(objFSO.GetParentFolderName(strPath)) Then objFSO.CreateFolder strPath 'Create Folder In Current Path Else CreateFileOrDir(objFSO.GetParentFolderName(strPath)) 'Recurse Creating Parent Folder CreateFileOrDir(strPath) 'Recurse Creating Current Folder End If End If Else If Not objFSO.FileExists(strPath) Then If objFSO.FolderExists(objFSO.GetParentFolderName(strPath)) Then objFSO.CreateTextFile strPath, True 'Create File In Current Path Else CreateFileOrDir(objFSO.GetParentFolderName(strPath)) 'Recurse Creating Parent Folder CreateFileOrDir(strPath) 'Recurse Creating Current Folder End If End If End If End If On Error Goto 0 End Sub ' *************************************************************************************************** ' Function SendBlatEmail - Sends Email Using Blat ' *************************************************************************************************** Private Sub SendBlatEmail(blatPath, blatProfile, strRecipients, strSubject, strBody, strAttachment) 'Need blat.exe, blat.dll, blat.lib On Error Resume Next Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject") Dim objShell: Set objShell = WScript.CreateObject("WScript.Shell") Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\")) 'Ensure Blat Exists If Not objFSO.FileExists(blatPath) Then If Not objFSO.FileExists(scriptPath & "blat.exe") Then Exit Sub Else blatPath = scriptPath & "blat.exe" End If End If 'Set Blat Email Command Dim commandText: commandText = chr(34) & blatPath & chr(34) commandText = commandText & " -p " & chr(34) & blatProfile & chr(34) commandText = commandText & " -to " & strRecipients commandText = commandText & " -subject " & chr(34) & strSubject & " " & chr(34) 'Keep Space to Prevent Escaping the Quote commandText = commandText & " -body " & chr(34) & strBody & " " & chr(34) 'Keep Space to Prevent Escaping the Quote 'Append Attachment(s) If objFSO.FileExists(strAttachment) Then commandText = commandText & " -attach " & chr(34) & strAttachment & chr(34) Else If objFSO.FileExists(scriptPath & strAttachment) Then commandText = commandText & " -attach " & chr(34) & scriptPath & strAttachment & chr(34) End If End If 'Send Blat Email objShell.run commandText, True Set objFSO = Nothing Set objShell = Nothing If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 End Sub ' *************************************************************************************************** ' Function Logger ' *************************************************************************************************** Private Sub Logger(fileName, logMessage, blnNewLog) On Error Resume Next Const ForReading = 1, ForWriting = 2, ForAppending = 8 Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject") Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\")) Dim logName If InStr(1,fileName,"\",1) > 0 Then logName = fileName If objFSO.DriveExists(objFSO.GetDriveName(logName)) Then If StrComp(objFSO.GetExtensionName(logName), "", 1) = 0 Then If Not objFSO.FolderExists(logName) Then If objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then objFSO.CreateFolder logName 'Create Folder In Current Path Exit Sub Else Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder Exit Sub End If End If Else If Not objFSO.FileExists(logName) Then If Not objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder End If End If End If End If Else logName = scriptPath & fileName End If Dim logFile If blnNewLog = True Then Set logFile = objFSO.CreateTextFile(logName, True) Else If objFSO.FileExists(logName) Then Set logFile = objFSO.OpenTextFile(logName, ForAppending, True) Else Set logFile = objFSO.CreateTextFile(logName, True) End If End If logFile.WriteLine logMessage logFile.Close Set objFSO = Nothing On Error Goto 0 End Sub
