Option Explicit
'=========================================================================
' DirMirror.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' 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@domain.com" '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
