Category Archives: Backup

Aug 05

DirMirror.vbs

Posted on by 
Option Explicit
'=========================================================================
' DirMirror.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://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

 

Mar 20

SyncToy21.vbs

Posted on by 
'=========================================================================
' SyncToy21.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 3/20/20114
' REQUIREMENTS: You must install SyncToy on the Workstation and manually run it to click on
' the agreement statement, otherwise this script will lock up and NEVER back up!!!
'=========================================================================
Option Explicit

' ------ SCRIPT CONFIGURATION ------
Const strContact = "backup@domain.com"
Dim syncToyExe: syncToyExe = ExpandEnv("%PROGRAMFILES%\SyncToy 2.1\SyncToy.exe")
Dim syncToyExeX86: syncToyExeX86 = ExpandEnv("%PROGRAMFILES(X86)%\SyncToy 2.1\SyncToy.exe")
Dim syncToyCmdExe: syncToyCmdExe = ExpandEnv("%PROGRAMFILES%\SyncToy 2.1\SyncToyCmd.exe")
Dim syncToyCmdExeX86: syncToyCmdExeX86 = ExpandEnv("%PROGRAMFILES(X86)%\SyncToy 2.1\SyncToyCmd.exe")
Dim blnAutoRun: blnAutoRun = True
Dim syncOperation: syncOperation = "echo"
Dim strBackupPath: strBackupPath = ExpandEnv("\\server\backups\%USERNAME%\")
Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
' ------ END CONFIGURATION ------

Call Main()

Private Sub Main()

    ' Create Objects
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )

    ' Set Folders for Backups
    Dim strDocuments: strDocuments = objShell.SpecialFolders("MyDocuments")
    Dim strMusic: strMusic = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\My Music")
    Dim strPictures: strPictures = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\My Pictures")
    Dim strVideos: strVideos = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\My Video")

    ' Ensure Backup Path Ends with Slash
    If Right(strBackupPath,1) <> "\" Then
        strBackupPath = strBackupPath & "\"
    End If

    ' Validate Folders for Backup
    Dim strResult: strResult = ""
    If Not objFSO.FolderExists(strDocuments) Then
        strResult = strResult & "- Missing Documents Folder" & vbCrLf
    End If
    If Not objFSO.FolderExists(strMusic) Then
        strResult = strResult & "- Missing Music Folder" & vbCrLf
    End If
    If Not objFSO.FolderExists(strPictures) Then
        strResult = strResult & "- Missing Pictures Folder" & vbCrLf
    End If
    If Not objFSO.FolderExists(strBackupPath) Then
        strResult = strResult & "- Missing Backup Folder" & vbCrLf
    End If

    ' Validate SyncToy Path
    If Not objFSO.FileExists(syncToyExe) Then
        If Not objFSO.FileExists(syncToyExeX86) Then
            strResult = strResult & "- Missing SyncToy.exe" & vbCrLf
        Else
            syncToyExe = syncToyExeX86
        End If
    End If
    If Not objFSO.FileExists(syncToyCmdExe) Then
        If Not objFSO.FileExists(syncToyCmdExeX86) Then
            strResult = strResult & "- Missing SyncToyCmd.exe" & vbCrLf
        Else
            syncToyCmdExe = syncToyCmdExeX86
        End If
    End If

    ' Ensure Everything Validated
    If strResult <> "" Then
        objShell.Popup "An ERROR occurred backing up your files" & vbCrLf & _
            strResult & vbCrLf & _
            "Please contact " & strContact _
            , 30, "ERROR Backing Up Documents!", vbOkOnly + vbCritical
        Wscript.Quit
    End If

    ' Determine Which Folders To Backup and Prompt to Backup
    Dim intAnswer
    Dim blnDocuments: blnDocuments = True
    Dim blnMusic: blnMusic = False
    Dim blnPictures: blnPictures = False
    Dim blnVideos: blnVideos = False
    If InStr(1,strMusic,strDocuments,1) > 0 AND InStr(1,strPictures,strDocuments,1) > 0 AND InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
    Elseif InStr(1,strMusic,strDocuments,1) > 0 AND InStr(1,strPictures,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    Elseif InStr(1,strMusic,strDocuments,1) > 0 AND InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
    Elseif InStr(1,strPictures,strDocuments,1) > 0 AND InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
    Elseif InStr(1,strMusic,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
         Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    Elseif InStr(1,strPictures,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
        ' Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    Elseif InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
    Else
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
        ' Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    End If

    'Validate Backup Folder Exists Or Try to Create Them
    strResult = ""
    If blnDocuments = True Then
        If ValidateFolder(strBackupPath & "Documents") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Documents" & vbCrLf
        End If
    End If
    If blnMusic = True Then
        If ValidateFolder(strBackupPath & "Music") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Music" & vbCrLf
        End If 
    End If
    If blnPictures = True Then
        If ValidateFolder(strBackupPath & "Pictures") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Pictures" & vbCrLf
        End If
    End If
    If blnVideos = True Then
        If ValidateFolder(strBackupPath & "Videos") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Videos" & vbCrLf
        End If
    End If

    ' Ensure Everything Validated
    If strResult <> "" Then
        objShell.Popup "An ERROR occurred backing up your files" & vbCrLf & _
            strResult & vbCrLf & _
            "Please contact " & strContact _
            , 30, "ERROR Backing Up Documents!", vbOkOnly + vbCritical
        Wscript.Quit
    End If

    ' Create Folder Pairs
    Call CreateSyncToyPairs(blnDocuments, strDocuments, blnMusic, strMusic, blnPictures, strPictures, blnVideos, strVideos)

    ' Run SyncToy Backup
    If blnDocuments = True Then
        Call RunSyncToy("Documents")
    End If
    If blnMusic = True Then
        Call RunSyncToy("Music")
    End If
    If blnPictures = True Then
        Call RunSyncToy("Pictures")
    End If
    If blnVideos = True Then
        Call RunSyncToy("Videos")
    End If

    ' Cleanup
    Set objFSO = Nothing
    Set objShell = Nothing

End Sub

Private Function ValidateFolder(ByVal strFolder)

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim blnResult: blnResult = True
    On Error Resume Next
    If Not objFSO.FolderExists(strFolder) Then
        objFSO.CreateFolder(strFolder)
    End If
    If Err.Number <> 0 Then
        Err.Clear
        blnResult = False
    End If
    On Error Goto 0

    ValidateFolder = blnResult

End Function

Private Sub CreateSyncToyPairs(ByVal bDoc, ByVal sDoc, ByVal bMus, ByVal sMus, ByVal bPic, ByVal sPic, ByVal bVid, ByVal sVid)

    ' Create Objects
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )

    ' Attempt to Delete Folder Pairs
    Call DeleteSyncToyPair(sDoc,"Documents")
    Call DeleteSyncToyPair(sMus,"Music")
    Call deleteSyncToyPair(sPic,"Pictures")
    Call deleteSyncToyPair(sVid,"Videos")

    ' Create Folder Pairs
    If bDoc = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sDoc & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Documents" & chr(34) & _
        ",name=Documents" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true  
    End If
    If bMus = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sMus & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Music" & chr(34) & _
        ",name=Music" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true
    End If
    If bPic = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sPic & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Pictures" & chr(34) & _
        ",name=Pictures" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true
    End If
    If bVid = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sVid & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Videos" & chr(34) & _
        ",name=Videos" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true
    End If

    Set objShell = Nothing

End Sub

Private Sub DeleteSyncToyPair(ByVal strPath, ByVal strPair)

    ' Detect if a Config File Exists in the leftFolder and try to Delete Folder Pair
    ' This will ensure all Left Folder Files Write to the Right Folder and Will Skip
    ' Duplicates.  Otherwise Files on the left will not write to the right if they are
    ' deleted from the right
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )
    Dim colFiles: Set colFiles = objFSO.GetFolder(strPath).Files
    Dim File, strErr
    For Each File in colFiles
        If InStr(1,File.Name,"SyncToy",1) > 0 AND StrComp(objFSO.GetExtensionName(File.Name),"dat",1) = 0 Then
            'SyncToy File Exists, Try to Delete Pair
            Call KillProcess("SyncToy.exe") 'Terminate SyncToy Processes Else a Delete Fails
            Call KillProcess("SyncToyCmd.exe")
            strErr = objShell.Run(chr(34) & syncToyExe & Chr(34) & " -u" & strPair, 0, false)
            'Cheap hack if it errors because the pair doesnt exist to kill the window
            Wscript.Sleep 10000
            Call KillProcess("SyncToy.exe")
            Call KillProcess("SyncToyCmd.exe")
        End If
    Next

    Set objFSO = Nothing
    Set objShell = Nothing

End Sub

Private Sub RunSyncToy(ByVal folderPair)

    ' Create Objects
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )

    ' Run SyncToy as Manual or Automated
    If blnAutoRun = False Then
        objShell.Run chr(34) & syncToyExe & chr(34)
    Else
        ' Set Path to SyncToyLog and Clear Log
        Dim syncToyLog: syncToyLog = ExpandEnv("%LOCALAPPDATA%\Microsoft\SyncToy\2.0\SyncToyLog.log")
        If InStr(1,syncToyLog,"%",1) > 0 Then
            syncToyLog = ExpandEnv("%USERPROFILE%\Local Settings\Application Data\Microsoft\SyncToy\2.0\SyncToyLog.log")
        End If
        If InStr(1,syncToyLog,"%",1) > 0 Then
            syncToyLog = "!~ERROR~!"
        End If
        If objFSO.FileExists(syncToyLog) Then
            Call Logger(syncToyLog, "", True)
        End If 

        ' Run Automated SyncToy Backup
        objShell.Run chr(34) & syncToyCmdExe & Chr(34) & " -R " & chr(34) & folderPair & chr(34), 1, true

        ' Parse SyncToyLog to Ensure It Successfully Ran
        Dim strError: strError = ""
        If objFSO.FileExists(syncToyLog) Then
            strError = ParseSyncToyLog(syncToyLog)
            If strError <> "" Then
                ' Error Detected in Sync
                objShell.Popup "An ERROR occurred backing up folder pair: " & folderPair & vbCrLf & _
                strError & vbCrLf & _
                "Please contact " & strContact _
                , 30, "ERROR Backing Up Files!", vbOkOnly + vbCritical
            End If
        Else
            ' Error Getting Log to Parse
            objShell.Popup "An ERROR occurred obtaining log file to check for errors after backing up folder pair: " & folderPair & vbCrLf & _
            "Please contact " & strContact _
            , 30, "ERROR Backing Up Files!", vbOkOnly + vbCritical
        End If

        'Copy SyncToy Log to Backup Path
        If objFSO.FIleExists(syncToyLog) Then
            objFSO.CopyFile syncToyLog, strBackupPath, True
        End If
    End If

    ' Cleanup
    Set objFSO = Nothing
    Set objShell = Nothing

End Sub

Private Function ParseSyncToyLog(ByVal strLog)

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Const ForReading = 1
    Dim objFile: Set objFile = objFSO.OpenTextFile(strLog, ForReading)
    Dim strLine
    Dim strResult: strResult = ""
    Dim blnAction: blnAction = True
    Dim blnWarning: blnWarning = False
    Dim blnError: blnError = False
    Do Until objFile.AtEndOfStream
        strLine = objFile.ReadLine
        If Len(strLine) > 0 Then
            ' Backup SyncToyLog for Archiving
            Call Logger(Replace(strLog,"SyncToyLog.log","SyncToyLog_Full.txt",1,1,1),strLine,False)

            ' Check If Actions Were Performed
            If InStr(1,strLine,"Found 0 actions to perform",1) > 0 Then
                blnAction = False
            End If

            ' Check If Warning Was Logged
            If InStr(1,strLine,"Warning:",1) > 0 Then
                blnWarning = True
                If strResult = "" Then
                    strResult = strLine
                Else
                    strResult = strResult & vbcrlf & strLine
                End If
            End If

            ' Check If Error Was Logged
            If InStr(1,strLine,"Error:",1) > 0 Then
                blnError = True
                If strResult = "" Then
                    strResult = strLine
                Else
                    strResult = strResult & vbcrlf & strLine
                End If
            End If
        End If
    Loop
    objFile.Close

    Set objFSO = Nothing

    ParseSyncToyLog = strResult

End Function

Private Sub KillProcess(ByVal strProcess)
    Dim strComputer: strComputer = "."
    Dim objWMIService: Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Dim colItems: Set colItems = objWMIService.ExecQuery("Select * From Win32_Process")
    Dim objItem
    For Each objItem in colItems
        If StrComp(objItem.Name, strProcess, 1) = 0 Then
            objItem.Terminate()
        End If
    Next
End Sub

Private Function ExpandEnv(ByVal strPath)

    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )
    ExpandEnv = objShell.ExpandEnvironmentStrings(strPath)
    Set objShell = Nothing

End Function

Private Sub Logger(fileName, logMessage, blnNewLog)

    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

End Sub

 

Jan 01

GroupBackupRestore.vbs

Posted on by 
'=========================================================================
' GroupBackupRestore.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 1/1/2011
' COMMENTS: This Script Will Bulk Backup Groups to a Text File and Can Also
' Restore the Groups After a Backup.  It is Useful to Restore Accidentally
' Deleted Groups, Migrating Groups Across Domains, and For Quickly Restoring
' Settings For Temporary Modifications Such as Removing and Restoring Message
' Restrictions. Parts of this Script Require Exchange DLL's like CDOEXM.DLL,
' So It's Recommended to Run on a Computer with Exchange Tools Installed.
'
' To Backup Groups, Pass the ADsPath or Dinstinguised Name of the
' Container/Organizational Unit to the RunBackup Function. The Results are
' Output to backup_<Date>.txt in the Current Directory by Default. I Recommend
' Keeping the Default To Prevent Accidentally Overwriting the Backup File.
'
' To Restore Groups, Pass the Name of the Backup File to the RunRestore Function.
' By Default, the Backup File is backup_Date.txt in the Current Directory.
'
' EXAMPLE: Call RunBackup("LDAP://CN=Users,DC=domain,DC=com")
'
' EXAMPLE: Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))
'          Call RunRestore(scriptPath & "backup.txt")
'=========================================================================
Option Explicit
' ------ BACKUP CONFIGURATION ------
Call RunBackup("LDAP://CN=Users,DC=domain,DC=com")
' ------ END CONFIGURATION ------

' ------ RESTORE CONFIGURATION ------
'Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))
'Call RunRestore(scriptPath & "backup.txt")
' ------ END CONFIGURATION ------

Wscript.Echo "Finished"

'**************************************************************************************************
'Sub RunBackup - Specify Root Search OU to Enumerate All Groups to Backup
'**************************************************************************************************
Private Sub RunBackup(strOU)

    On Error Resume Next

    strOU = Replace(strOU,"LDAP://","",1,1,1)   'Ensure DN not ADS Path
    Const ADS_SCOPE_SUBTREE = 2
    Dim objConnection: Set objConnection = CreateObject("ADODB.Connection")
    Dim objCommand: Set objCommand = CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Page Size") = 1000   'Override the Return 1000 Results Default
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE    'Include Sub OU's
    objCommand.CommandText = "SELECT distinguishedname FROM 'LDAP://" & strOU & "' WHERE objectClass='group'"
    Dim objRecordSet: Set objRecordSet = objCommand.Execute
    If Err.Number <> 0 Then
        Wscript.Echo "!~ERROR~! Running Backup!" & vbCrLf & "Invalid OU: " & strOU & vbCrLf & vbCrLf & "Quitting Script"
        Err.Clear
        Wscript.Quit
    End If
    Dim strDate: strDate = Day(Now) & Month(Now) & Year(Now) & Hour(Now) & Minute(Now) & Second(Now)
    Call Logger("backup_" & strDate & ".txt","", True)
    objRecordSet.MoveFirst
    Do Until objRecordSet.EOF
        'Backup Groups
        Call Logger("backup_" & strDate & ".txt",BackupGroup(objRecordSet.Fields("distinguishedname").Value), False)
        objRecordSet.MoveNext
    Loop

    On Error Goto 0

End Sub

'**************************************************************************************************
'Function BackupGroup - Specify the Group Distinguished Name and Backs Up to backup.txt
'**************************************************************************************************
Private Function BackupGroup(groupDN)

    On Error Resume Next

    Dim strResult: strResult = "[group]" & vbCrLf & "group|" & groupDN
    Dim objGroup: Set objGroup = GetObject("LDAP://" & groupDN)
    strResult = strResult & vbCrLf & "name|" & objGroup.CN
    strResult = strResult & vbCrLf & "samaccountname|" & objGroup.sAMAccountName

    Const ADS_GROUP_TYPE_GLOBAL_GROUP = &h2
    Const ADS_GROUP_TYPE_LOCAL_GROUP = &h4
    Const ADS_GROUP_TYPE_UNIVERSAL_GROUP = &h8
    Const ADS_GROUP_TYPE_SECURITY_ENABLED = &h80000000
    Dim intgroupType: intgroupType = objGroup.groupType
    If intGroupType AND ADS_GROUP_TYPE_LOCAL_GROUP Then
        strResult = strResult & vbCrLf & "scope|Domain Local"
    ElseIf intGroupType AND ADS_GROUP_TYPE_GLOBAL_GROUP Then
        strResult = strResult & vbCrLf & "scope|Global"
    ElseIf intGroupType AND ADS_GROUP_TYPE_UNIVERSAL_GROUP Then
        strResult = strResult & vbCrLf & "scope|Universal"
    Else
        strResult = strResult & vbCrLf & "scope|Unknown"
    End If
    If intGroupType AND ADS_GROUP_TYPE_SECURITY_ENABLED Then
        strResult = strResult & vbCrLf & "type|Security"
    Else
        strResult = strResult & vbCrLf & "type|Distribution"
    End If

    strResult = strResult & vbCrLf & "mail|" & objGroup.mail
    strResult = strResult & vbCrLf & "displayname|" & objGroup.displayName

    Dim strManagedBy: strManagedBy = objGroup.Get("managedBy")
    If Err.Number <> 0 Then
        strResult = strResult & vbCrLf & "manager|None"
        Err.Clear
    Else
        strResult = strResult & vbCrLf & "manager|" & strManagedBy
    End If

    Dim objMember
    For Each objMember in objGroup.Members
        strResult = strResult & vbCrLf & "member|" & objMember.distinguishedName
    Next

    Const cdoexmAccept = 0
    Const cdoexmReject = 1
    Const E_ADS_PROPERTY_NOT_FOUND  = &h8000500D
    If Not objGroup.Mail = "" Then
        If objGroup.msExchRequireAuthToSendTo = True Then
            strResult = strResult & vbCrLf & "authentication|True"
        Else
            strResult = strResult & vbCrLf & "authentication|False"
        End If
        If IsNull(objGroup.RestrictedAddressList) OR UBound(objGroup.RestrictedAddressList) < 0 Then
            strResult = strResult & vbCrLf & "Restriction|from everyone"
        Else
            If objGroup.RestrictedAddresses = cdoexmAccept Then
                strResult = strResult & vbCrLf & "festriction|only from"
            Else
                strResult = strResult & vbCrLf & "restriction|from everyone except"
            End If
            For Each objMember in objGroup.RestrictedAddressList
                strResult = strResult & vbCrLf & "restrict|" & objMember
            Next
        End If
    End If

    If Err.Number <> 0 Then
        strResult = "[group]" & vbCrLf & "group|" & groupDN & vbCrLf & "!~ERROR~!"
        Err.Clear
    End If
    BackupGroup = strResult & vbCrLf & "[end]" & vbCrLf

    On Error Goto 0

End Function

'**************************************************************************************************
'Sub Run Restore - Restores Groups From the Specified Backup File
'**************************************************************************************************
Private Sub RunRestore(backupFile)

    On Error Resume Next

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))
    Const ForReading = 1
    If Not objFSO.FileExists(backupFile) Then
        Wscript.Echo "!~ERROR~! Running Restore!" & vbCrLf & "Backup File: " & backupFile & vbCrLf & vbCrLf & "Quitting Script"
        Wscript.Quit
    End If
    Call Logger("restore.txt", "", True)
    Dim objTextFile: Set objTextFile = objFSO.OpenTextFile(backupFile, ForReading)
    Dim strLine
    Dim strGroup, strName, strSamaccountname, strScope, strType, strMail, strDisplayName, strManager, i
    Dim strAuth, strRestriction, j
    Dim arrMember(), arrRestrict()
    Do Until objTextFile.AtEndOfStream
        strLine = objTextFile.Readline
        If StrComp(Mid(strLine,1,7),"[group]",1) = 0 Then
            'Reset Variables
            strGroup = ""
            strName = ""
            strSamaccountname = ""
            strScope = ""
            strType = ""
            strMail = ""
            strDisplayName = ""        
            strManager = ""
            i = 0
            strAuth = ""
            strRestriction = ""
            j = 0
            Erase arrMember
            Erase arrRestrict
            Call Logger("restore.txt", "[group]", False)   
        Elseif StrComp(Mid(strLine,1,6),"group|",1) = 0 Then
            strGroup = Mid(strLine,7,Len(strLine)-6)           
        Elseif StrComp(Mid(strLine,1,5),"name|",1) = 0 Then
            strName = Mid(strLine,6,Len(strLine)-5)
        Elseif StrComp(Mid(strLine,1,15),"samaccountname|",1) = 0 Then
            strSamaccountname = Mid(strLine,16,Len(strLine)-15)
        Elseif StrComp(Mid(strLine,1,6),"scope|",1) = 0 Then
            strScope = Mid(strLine,7,Len(strLine)-6)
        Elseif StrComp(Mid(strLine,1,5),"type|",1) = 0 Then
            strType = Mid(strLine,6,Len(strLine)-5)
        Elseif StrComp(Mid(strLine,1,5),"mail|",1) = 0 Then
            strMail = Mid(strLine,6,Len(strLine)-5)    
        Elseif StrComp(Mid(strLine,1,12),"displayname|",1) = 0 Then
            strDisplayName = Mid(strLine,13,Len(strLine)-12)
        Elseif StrComp(Mid(strLine,1,8),"manager|",1) = 0 Then
            strManager = Mid(strLine,9,Len(strLine)-8)
        Elseif StrComp(Mid(strLine,1,7),"member|",1) = 0 Then
            'blnUsers = True           
            ReDim Preserve arrMember(i)
            arrMember(i) = Mid(strLine,8,Len(strLine)-7)
            i = i + 1
        Elseif StrComp(Mid(strLine,1,15),"authentication|",1) = 0 Then
            If StrComp(Trim(Mid(strLine,16,Len(strLine)-15)),"true",1) = 0 Then
                strAuth = True
            Else
                strAuth = False
            End If
        Elseif StrComp(Mid(strLine,1,12),"restriction|",1) = 0 Then
            strRestriction = Mid(strLine,13,Len(strLine)-12)
        Elseif StrComp(Mid(strLine,1,9),"restrict|",1) = 0 Then
            ReDim Preserve arrRestrict(j)
            arrRestrict(j) = Mid(strLine,10,Len(strLine)-9)
            j = j + 1
        Elseif StrComp(Mid(strLine,1,5),"[end]",1) = 0 Then
            'Ensure Group Exists
            If CheckObjExist(strGroup) Then
                Call Logger("restore.txt", "Exists" & vbTab & "group|" & strGroup, False)
            Else
                If CreateGroup(strGroup, strSamaccountname, strScope & " " & strType, strMail, strDisplayname) = True Then
                    Call Logger("restore.txt", "Added" & vbTab & "group|" & strGroup, False)
                Else
                    Call Logger("restore.txt", "!~ERROR~!" & vbTab & "group|" & strGroup, False)
                End If
            End If

            'Ensure Manager is Set
            If strComp(strManager,"None",1) = 0 Then
                Call Logger("restore.txt", "Skip" & vbTab & "manager|" & strManager, False)
            Else
                If CheckGroupManager(strGroup,strManager) = True Then
                    Call Logger("restore.txt", "Exists" & vbTab & "manager|" & strManager, False)
                Else
                    If ModifyGroupManager(strGroup,strManager) = True Then
                        Call Logger("restore.txt", "Modified" & vbTab & "manager|" & strManager, False)
                    Else
                        Call Logger("restore.txt", "!~ERROR~!" & vbTab & "manager|" & strManager, False)
                    End If
                End If             
            End If

            'Ensure all Members are a member
            For i = LBound(arrMember) to UBound(arrMember)
                If Err.Number <> 0 Then
                    Err.Clear
                    Call Logger("restore.txt", "SKIP" & vbTab & "member|none", False)
                Else
                    'Ensure User Exists
                    If CheckObjExist(arrMember(i)) Then
                        'Check if User is A member of The Group
                        If CheckUserInGroup(arrMember(i),strGroup) = True Then
                            Call Logger("restore.txt", "Exists" & vbTab & "member|" & arrMember(i), False)
                        Else
                            'User Not a Member, Try to Add User to Group
                            If AddUserToGroup(arrMember(i),strGroup) = True Then
                                Call Logger("restore.txt", "Added" & vbTab & "member|" & arrMember(i), False)
                            Else
                                Call Logger("restore.txt", "!~ERROR~!" & vbTab & "member|" & arrMember(i), False)
                            End If
                        End If
                    Else
                        Call Logger("restore.txt", "!~ERROR~!" & vbTab & "member|" & arrMember(i), False)
                    End If
                End If
            Next

            'Ensure Restrictions Are Set
            If Not strRestriction = "" Then
                'Set Authentication
                If RestoreAuthentication(strGroup, strAuth) = True Then
                    Call Logger("restore.txt", "Modified" & vbTab & "authentication|" & strAuth, False)
                Else
                    Call Logger("restore.txt", "!~ERROR~!" & vbTab & "authentication|" & strAuth, False)
                End If
                'Restore Restriction Type and List
                If RestoreRestrictions(strGroup, strRestriction, arrRestrict) = True Then
                    Call Logger("restore.txt", "Modified" & vbTab & "restriction|" & strRestriction, False)
                    For j = LBound(arrRestrict) to UBound(arrRestrict)
                        Call Logger("restore.txt", "Added" & vbTab & "restrict|" & arrRestrict(j), False)
                    Next
                Else
                    Call Logger("restore.txt", "!~ERROR~!" & vbTab & "restriction|" & strRestriction, False)
                    For j = LBound(arrRestrict) to UBound(arrRestrict)
                        Call Logger("restore.txt", "!~ERROR~!" & vbTab & "restrict|" & arrRestrict(j), False)
                    Next
                End If
            End If
        Else
            'Ignore All other lines
        End If

    Loop

    On Error Goto 0

End Sub

'**************************************************************************************************
'Function CheckObjExist - Checks If An Object Exists in AD by Trying to Bind to It
'**************************************************************************************************
Private Function CheckObjExist(objDN)

    On Error Resume Next

    Dim adObject: Set adObject = GetObject("LDAP://" & objDN)
    If Err.Number <> 0 Then
        CheckObjExist = FALSE
        Err.Clear
    Else
        CheckObjExist = TRUE
    End If

    On Error Goto 0

End Function

'**************************************************************************************************
'Function CreateGroup - Creates Group Based on Passed in Parameters -MUST BE RUN ON EXCHANGE SERVER!
'**************************************************************************************************
Private Function CreateGroup(groupDN, strSamAccountName, scopeType, strMail, strDisplayname)

    On Error Resume Next

    'Create Group
    Const ADS_GROUP_TYPE_GLOBAL_GROUP = &h2
    Const ADS_GROUP_TYPE_LOCAL_GROUP = &h4
    Const ADS_GROUP_TYPE_UNIVERSAL_GROUP = &h8
    Const ADS_GROUP_TYPE_SECURITY_ENABLED = &h80000000
    groupDN = Replace(groupDN,"LDAP://","",1,1,1)   'Ensure DN not ADS Path
    Dim objOU: Set objOU = GetObject("LDAP://" & Right(groupDN,Len(groupDN)-InStr(1,groupDN,",",1)))
    Dim objGroup: Set objGroup = objOU.Create("Group", Left(groupDN,InStr(1,groupDN,",",1)-1))
    objGroup.Put "sAMAccountName", strSamAccountName
    Select Case scopeType
        Case "Domain Local Distribution"
            objGroup.Put "groupType", ADS_GROUP_TYPE_LOCAL_GROUP
        Case "Global Security"
            objGroup.Put "groupType", ADS_GROUP_TYPE_GLOBAL_GROUP Or ADS_GROUP_TYPE_SECURITY_ENABLED
        Case "Universal Distribution"
            objGroup.Put "groupType", ADS_GROUP_TYPE_UNIVERSAL_GROUP
        Case "Universal Security"
            objGroup.Put "groupType", ADS_GROUP_TYPE_UNIVERSAL_GROUP Or ADS_GROUP_TYPE_SECURITY_ENABLED        
    End Select
    objGroup.SetInfo

    'Email Enable
    If Not Trim(strMail) = "" Then
        objGroup.Put "mail", strMail
        objGroup.Put "displayname", strDisplayname
        objGroup.MailEnable
        objGroup.SetInfo
    End If

    If Err.Number <> 0 Then
        CreateGroup = FALSE
        Err.Clear
    Else
        CreateGroup = TRUE
    End If

    On Error Goto 0

End Function

'**************************************************************************************************
'Function CheckGroupManager - Checks If the Specified User Is Set As The Manager On the Specified Group
'**************************************************************************************************
Private Function CheckGroupManager(groupDN,managerDN)

    On Error Resume Next

    groupDN = Replace(groupDN,"LDAP://","",1,1,1)   'Ensure DN not ADS Path
    Dim objGroup: Set objGroup = GetObject("LDAP://" & groupDN)
    Dim strManagedBy: strManagedBy = objGroup.Get("managedBy")
    Dim strResult: strResult = FALSE
    If Err.Number <> 0 Then
        Err.Clear
    Else
        If strComp(strManagedBy,managerDN,1) = 0 Then
            strResult = TRUE
        End If
    End If
    CheckGroupManager = strResult

    On Error Goto 0

End Function

'**************************************************************************************************
'Function ModifyGroupManager - Sets Specified User As Group Manager On The Specified Group
'**************************************************************************************************
Private Function ModifyGroupManager(groupDN,managerDN)

    On Error Resume Next

    'Set Group Manager
    groupDN = Replace(groupDN,"LDAP://","",1,1,1)   'Ensure DN not ADS Path
    managerDN = Replace(managerDN,"LDAP://","",1,1,1)   'Ensure DN not ADS Path
    Dim objGroup: Set objGroup = GetObject("LDAP://" & groupDN)
    objGroup.Put "managedBy", managerDN
    objGroup.SetInfo

    'Allow Manager to Update Member List
    Const ADS_ACETYPE_ACCESS_ALLOWED_OBJECT = &H5
    Const ADS_FLAG_OBJECT_TYPE_PRESENT = &H01
    Const ADS_RIGHT_DS_WRITE_PROP = &H20
    Const ADS_OBJECT_WRITE_MEMBERS = "{BF9679C0-0DE6-11D0-A285-00AA003049E2}"
    Const ADS_ACEFLAG_INHERIT_ACE = &H00002
    Const ADS_ACEFLAG_DONT_INHERIT_ACE = &H0
    Dim objRootDSE: Set objRootDSE = GetObject("LDAP://rootDSE")
    Dim strDomain: strDomain = "LDAP://" & objRootDSE.Get("defaultNamingContext")
    Dim objDomain: Set objDomain = GetObject(strDomain)
    Dim objUser: Set objUser = GetObject("LDAP://" & objGroup.Get("managedBy"))
    Dim objSecurityDescriptor: Set objSecurityDescriptor = objGroup.Get("ntSecurityDescriptor")
    Dim objDACL: Set objDACL = objSecurityDescriptor.DiscretionaryACL
    Dim objACE: Set objACE = CreateObject("AccessControlEntry")
    objACE.Trustee = Replace(objDomain.Name,"DC=","",1,1,1) & "\" & objUser.Get("sAMAccountName")
    objACE.AccessMask = ADS_RIGHT_DS_WRITE_PROP
    objACE.AceFlags = ADS_ACEFLAG_DONT_INHERIT_ACE
    objACE.AceType = ADS_ACETYPE_ACCESS_ALLOWED_OBJECT
    objACE.Flags = ADS_FLAG_OBJECT_TYPE_PRESENT
    objACE.objectType = ADS_OBJECT_WRITE_MEMBERS
    objDACL.AddAce(objACE)
    objSecurityDescriptor.DiscretionaryACL = objDACL
    objGroup.Put "ntSecurityDescriptor", Array(objSecurityDescriptor)
    objGroup.SetInfo

    If Err.Number <> 0 Then
        ModifyGroupManager = FALSE
        Err.Clear
    Else
        ModifyGroupManager = TRUE
    End If

    On Error Goto 0

End Function

'**************************************************************************************************
'Function CheckUserInGroup - Checks If Specified User Is a Member of The Specified Group
'**************************************************************************************************
Private Function CheckUserInGroup(userDN,groupDN)

    On Error Resume Next

    groupDN = Replace(groupDN,"LDAP://","",1,1,1)   'Ensure DN not ADS Path
    userDN = Replace(userDN,"LDAP://","",1,1,1) 'Ensure DN not ADS Path
    Dim objGroup: Set objGroup = GetObject("LDAP://" & groupDN)
    Dim objMember
    Dim strResult: strResult = FALSE
    For Each objMember in objGroup.Members
        If strComp(objMember.distinguishedName, userDN,1) = 0 Then
            strResult = TRUE
        End If
    Next

    CheckUserInGroup = strResult

    On Error GoTo 0

End Function

'**************************************************************************************************
'Function AddUserToGroup - Adds Specified User to Specified Group
'**************************************************************************************************
Private Function AddUserToGroup(userDN,groupDN)

    On Error Resume Next

    groupDN = Replace(groupDN,"LDAP://","",1,1,1)   'Ensure DN not ADS Path
    userDN = Replace(userDN,"LDAP://","",1,1,1) 'Ensure DN not ADS Path
    Dim objUser: Set objUser = GetObject("LDAP://" & userDN)
    Dim objGroup: Set objGroup = GetObject("LDAP://" & groupDN)
    objGroup.Add(objUser.ADsPath)
    If Err.Number <> 0 Then
        AddUserToGroup = FALSE
    Else
        AddUserToGroup = TRUE
    End If

    On Error GoTo 0

End Function

'**************************************************************************************************
'Function RestoreAuthentication - Enable/Disable Accept Messages From Authenticated Users Only On
'                                 an Email Enabled Group
'**************************************************************************************************
Private Function RestoreAuthentication(groupDN, blnAuth)

    On Error Resume Next

    groupDN = Replace(groupDN,"LDAP://","",1,1,1)   'Ensure DN not ADS Path
    Dim objGroup: Set objGroup = GetObject("LDAP://" & groupDN)
    objGroup.msExchRequireAuthToSendTo = blnAuth
    objGroup.SetInfo

    If Err.Number <> 0 Then
        RestoreAuthentication = FALSE
    Else
        RestoreAuthentication = TRUE
    End If

    On Error GoTo 0

End Function

'**************************************************************************************************
'Function RestoreRestrictions - Sets Restriction Type and Restriction Lists On Email Enabled Groups
'**************************************************************************************************
Private Function RestoreRestrictions(groupDN, restrictionType, arrMembers)

    On Error Resume Next

    groupDN = Replace(groupDN,"LDAP://","",1,1,1)   'Ensure DN not ADS Path
    Dim objGroup: Set objGroup = GetObject("LDAP://" & groupDN)
    Const cdoexmAccept = 0
    Const cdoexmReject = 1
    If StrComp(Trim(restrictionType),"from everyone",1) = 0 Then
        objGroup.RestrictedAddresses = cdoexmAccept
    Elseif StrComp(Trim(restrictionType),"only from",1) = 0 Then
        objGroup.RestrictedAddresses = cdoexmAccept
    Elseif StrComp(Trim(restrictionType),"from everyone except",1) Then
        objGroup.RestrictedAddresses = cdoexmReject
    End If
    objGroup.RestrictedAddressList = arrMembers
    objGroup.SetInfo

    If Err.Number <> 0 Then
        RestoreRestrictions = FALSE
    Else
        RestoreRestrictions = TRUE
    End If

    On Error GoTo 0

End Function

'**************************************************************************************************
'Sub Logger - Specify Log Name, Message, and If It Should Make a New Log or Append an Existing Log
'**************************************************************************************************
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

 

Jan 01

NTBackup.vbs

Posted on by 
'=========================================================================
' NTBackup.vbs
' VERSION: 2.2 - Modified backupDestination to auto include the backupTitle as the end directory
' 2.1 - Fixed potential error on blat attachments
' 2.0 - Complete rewrite
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 3/7/2013
' REQUIREMENTS:
' - NTBackup.exe 2000, XP, 2003
' - A .bks file of directories to back up (Note: Best to Selct in NTBackup and Save Selection)
' - 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:
' Version 2.0 is a complete rewrite and I suggest you switch to this if using an earlier
' version. It corrects some small issues, improves deployment, and simplifies usage.
' The script is designed to automate backups with the task schedular, and email
' results using blat. It is capable of backing up local or remote files as long as the
' account it is running under has the appropriate permissions. It is designed to retain
' backups using weekly retention schedules and I would suggest a minimum of 2 weeks
' which leaves you with a weeks worth of backups while the other overwrites.
' Assuming you use 2 weeks of backups starting on Friday January 7, 2011
' you would need the following copies of this script and scheduled tasks.
'
' EXAMPLE WEEK1: Server_Full1.vbs, Server_Inc01.vbs, Server_IncA1.vbs
' Fri - Server_Full1.vbs 9:00PM, run every other week, starting Jan 7, 2011
'         ------ SCRIPT CONFIGURATION ------
'       Dim backupTitle: backupTitle = "SERVERNAME" 'Name of the Server to Backup
'       Dim backupType: backupType = "Full" 'Full, Inc
'       Dim backupOverwrite: backupOverwrite = True 'Overwrite Incremental Backup
'       Dim backupWeek: backupWeek = 1 'Modify to match the backup week (Ex: 1, 2...etc)
'       Dim backupDestination: backupDestination = "E:\Backups\" 'Local Drive(E:\Backups\) or Network Drive (\\server\share\)
'       Dim emailBlatExe: emailBlatExe = "" 'Custom Path to Blat.exe Default is Same Folder as Script
'       Dim emailProfile: emailProfile = "ALERT" 'Blat Profile Name See (http://www.blat.net) For Info
'       Dim emailRecipient: emailRecipient = "EMAIL@DOMAIN.COM" 'Email to Receive Backup Result
'         ------ END CONFIGURATION ------
' Mon - Server_IncO1.vbs 9:00PM, run every other week, starting Jan 10, 2011
'         ------ SCRIPT CONFIGURATION ------
'       Dim backupTitle: backupTitle = "SERVERNAME" 'Name of the Server to Backup
'       Dim backupType: backupType = "Inc" 'Full, Inc
'       Dim backupOverwrite: backupOverwrite = True 'Overwrite Incremental Backup
'       Dim backupWeek: backupWeek = 1 'Modify to match the backup week (Ex: 1, 2...etc)
'       Dim backupDestination: backupDestination = "E:\Backups\" 'Local Drive(E:\Backups\) or Network Drive (\\server\share\)
'       Dim emailBlatExe: emailBlatExe = "" 'Custom Path to Blat.exe Default is Same Folder as Script
'       Dim emailProfile: emailProfile = "ALERT" 'Blat Profile Name See (http://www.blat.net) For Info
'       Dim emailRecipient: emailRecipient = "EMAIL@DOMAIN.COM" 'Email to Receive Backup Result
'         ------ END CONFIGURATION ------
' Tue, Wed, Thu - Server_IncA1.vbs 9:00PM, run every other week, starting Jan 11, 2011
'         ------ SCRIPT CONFIGURATION ------
'       Dim backupTitle: backupTitle = "SERVERNAME" 'Name of the Server to Backup
'       Dim backupType: backupType = "Inc" 'Full, Inc
'       Dim backupOverwrite: backupOverwrite = False 'Overwrite Incremental Backup
'       Dim backupWeek: backupWeek = 1 'Modify to match the backup week (Ex: 1, 2...etc)
'       Dim backupDestination: backupDestination = "E:\Backups\" 'Local Drive(E:\Backups\) or Network Drive (\\server\share\)
'       Dim emailBlatExe: emailBlatExe = "" 'Custom Path to Blat.exe Default is Same Folder as Script
'       Dim emailProfile: emailProfile = "ALERT" 'Blat Profile Name See (http://www.blat.net) For Info
'       Dim emailRecipient: emailRecipient = "EMAIL@DOMAIN.COM" 'Email to Receive Backup Result
'         ------ END CONFIGURATION ------
'
' EXAMPLE WEEK2: Server_Full2.vbs, Server_Inc02.vbs, Server_IncA2.vbs
' Fri - Server_Full2.vbs 9:00PM, run every other week, starting Jan 14, 2011
'         ------ SCRIPT CONFIGURATION ------
'       Dim backupTitle: backupTitle = "SERVERNAME" 'Name of the Server to Backup
'       Dim backupType: backupType = "Full" 'Full, Inc
'       Dim backupOverwrite: backupOverwrite = True 'Overwrite Incremental Backup
'       Dim backupWeek: backupWeek = 2 'Modify to match the backup week (Ex: 1, 2...etc)
'       Dim backupDestination: backupDestination = "E:\Backups\" 'Local Drive(E:\Backups\) or Network Drive (\\server\share\)
'       Dim emailBlatExe: emailBlatExe = "" 'Custom Path to Blat.exe Default is Same Folder as Script
'       Dim emailProfile: emailProfile = "ALERT" 'Blat Profile Name See (http://www.blat.net) For Info
'       Dim emailRecipient: emailRecipient = "EMAIL@DOMAIN.COM" 'Email to Receive Backup Result
'         ------ END CONFIGURATION ------
' Mon - Server_IncO2.vbs 9:00PM, run every other week, starting Jan 17, 2011
'         ------ SCRIPT CONFIGURATION ------
'       Dim backupTitle: backupTitle = "SERVERNAME" 'Name of the Server to Backup
'       Dim backupType: backupType = "Inc" 'Full, Inc
'       Dim backupOverwrite: backupOverwrite = True 'Overwrite Incremental Backup
'       Dim backupWeek: backupWeek = 2 'Modify to match the backup week (Ex: 1, 2...etc)
'       Dim backupDestination: backupDestination = "E:\Backups\" 'Local Drive(E:\Backups\) or Network Drive (\\server\share\)
'       Dim emailBlatExe: emailBlatExe = "" 'Custom Path to Blat.exe Default is Same Folder as Script
'       Dim emailProfile: emailProfile = "ALERT" 'Blat Profile Name See (http://www.blat.net) For Info
'       Dim emailRecipient: emailRecipient = "EMAIL@DOMAIN.COM" 'Email to Receive Backup Result
'         ------ END CONFIGURATION ------
' Tue, Wed, Thu - Server_IncA2.vbs 9:00PM, run every other week, starting Jan 18, 2011
'         ------ SCRIPT CONFIGURATION ------
'       Dim backupTitle: backupTitle = "SERVERNAME" 'Name of the Server to Backup
'       Dim backupType: backupType = "Inc" 'Full, Inc
'       Dim backupOverwrite: backupOverwrite = False 'Overwrite Incremental Backup
'       Dim backupWeek: backupWeek = 2 'Modify to match the backup week (Ex: 1, 2...etc)
'       Dim backupDestination: backupDestination = "E:\Backups\" 'Local Drive(E:\Backups\) or Network Drive (\\server\share\)
'       Dim emailBlatExe: emailBlatExe = "" 'Custom Path to Blat.exe Default is Same Folder as Script
'       Dim emailProfile: emailProfile = "ALERT" 'Blat Profile Name See (http://www.blat.net) For Info
'       Dim emailRecipient: emailRecipient = "EMAIL@DOMAIN.COM" 'Email to Receive Backup Result
'         ------ END CONFIGURATION ------
'
' EXAMPLE .BKS FILE: Server.bks
' D:\Shares\Users\
' \\server\share\
'=========================================================================
Option Explicit
On Error Resume Next

' ------ SCRIPT CONFIGURATION ------
Dim backupTitle: backupTitle = "SERVERNAME" 'Name of the Server to Backup
Dim backupType: backupType = "Full" 'Full, Inc
Dim backupOverwrite: backupOverwrite = True 'Overwrite Incremental Backup
Dim backupWeek: backupWeek = 1 'Modify to match the backup week (Ex: 1, 2...etc)
Dim backupDestination: backupDestination = "E:\Backups\" 'Local Drive(E:\Backups\) or Network Drive (\\server\share\)
Dim emailBlatExe: emailBlatExe = "" 'Custom Path to Blat.exe Default is Same Folder as Script
Dim emailProfile: emailProfile = "ALERT" 'Blat Profile Name See (http://www.blat.net) For Info
Dim emailRecipient: emailRecipient = "EMAIL@DOMAIN.COM" 'Email to Receive Backup Result
' ------ END CONFIGURATION ------

'Create Log File
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "[ " & WScript.ScriptName & " ] " & vbCrLf & Now(), True)

' Create Objects
Dim objShell: Set objShell = WScript.CreateObject("WScript.Shell")
Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))

'Set NT Backup Global Variables
Dim ntBackupLogDir: ntBackupLogDir = objShell.ExpandEnvironmentStrings("%USERPROFILE%\Local Settings\Application Data\Microsoft\Windows NT\NTBackup\data\")
Dim bksFile: bksFile = scriptPath & backupTitle & ".bks"
Dim backupName: backupName = backupTitle & "_" & backupType & backupWeek
If Mid(backupDestination,Len(backupDestination),1) <> "\" Then
    backupDestination = backupDestination & "\"
End If
backupDestination = backupDestination & backupTitle
If Mid(backupDestination,Len(backupDestination),1) <> "\" Then
    backupDestination = backupDestination & "\"
End If
Dim bkfFile: bkfFile = backupDestination & backupName & ".bkf"
Dim ntBackupExe: ntBackupExe = objShell.ExpandEnvironmentStrings("%SYSTEMROOT%\system32\ntbackup.exe")

'Log Variables
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), vbCrLf & "[ Variables ]", False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "backupTitle = " & backupTitle, False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "backupType = " & backupType, False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "backupOverwrite = " & backupOverwrite, False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "backupWeek = " & backupWeek, False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "backupDestination = " & backupDestination, False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "emailProfile = " & emailProfile, False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "emailRecipient = " & emailRecipient, False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "ntBackupLogDir = " & ntBackupLogDir, False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "bksFile = " & bksFile, False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "backupName = " & backupName, False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "bkfFile = " & bkfFile, False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "ntBackupExe = " & ntBackupExe, False)

'Verify Before Continuing
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), vbCrLf & "[ Verify NTBackup.exe ]", False)
Call VerifyFileOrDir(ntBackupExe, False, False, Replace(WScript.ScriptFullName,".vbs",".log"))

Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), vbCrLf & "[ Verify NT Backup Log Directory ]", False)
Call VerifyFileOrDir(ntBackupLogDir, True, False, Replace(WScript.ScriptFullName,".vbs",".log"))

Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), vbCrLf & "[ Verify NT Backup Selection File (.bks) ]", False)
Call VerifyFileOrDir(bksFile, True, True, Replace(WScript.ScriptFullName,".vbs",".log"))

Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), vbCrLf & "[ Verify NT Backup Destination Directory ]", False)
Call VerifyFileOrDir(backupDestination, True, True, Replace(WScript.ScriptFullName,".vbs",".log"))

'Get Backup Selections
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), vbCrLf & "[ NT Backup Selections ]", False)
Dim ntBackupSelection: ntBackupSelection = GetBackupSelection(bksFile)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), ntBackupSelection, False)

'Run NT Backup
Dim startTime: startTime = Now()
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), vbCrLf & "[ NT Backup ]", False)
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "Start Time: " & startTime, False)
Call RunNTBackup(backupType, backupOverwrite, ntBackupExe, bksFile, backupName, bkfFile, Replace(WScript.ScriptFullName,".vbs",".log"))
Dim endTime: endTime = Now()
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "End Time: " & endTime, False)

'Get NT Backup Results
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), vbCrLf & "[ NT Backup Results ]", False)
Dim ntBackupResult: ntBackupResult = GetNTBackupResult(".", startTime, endTime, Replace(WScript.ScriptFullName,".vbs",".log"))
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), "Returned Result = " & ntBackupResult, False)

'Find NT Backup Log File
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), vbCrLf & "[ Find NT Backup Log File ]", False)
Dim ntBackupLogFile: ntBackupLogFile = GetNTBackupLog(ntBackupLogDir, startTime, endTime, Replace(WScript.ScriptFullName,".vbs",".log"))

'Set Blat Email Variables and Email Results
Call Logger(Replace(WScript.ScriptFullName,".vbs",".log"), vbCrLf & "[ Email Results ]", False)
Dim emailSubject: emailSubject = "NTBackup " & backupTitle & " - " & ntBackupResult
Dim emailBody: emailBody = backupName & " - " & ntBackupResult & " Backing up:" & "|" & ntBackupSelection
emailBody = ReplaceLineBreaks(emailBody)
Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, ntBackupLogFile, Replace(WScript.ScriptFullName,".vbs",".log"))

'Finish Script
Set objShell = Nothing

Private Sub VerifyFileOrDir(strPath, blnCreate, blnUnicode, strLog)

    On Error Resume Next

    Dim objFile
    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
                    If blnCreate = True Then
                        objFSO.CreateFolder strPath 'Create Folder In Current Path
                        'LOG CREATING FOLDER
                        If Err.Number <> 0 Then
                            Err.Clear
                            Call Logger(strLog, "Err Creating: " & strPath, False)
                            Call Logger(strLog, "Verification Failed - Quitting Script!", False)
                            Wscript.Quit
                        Else
                            Call Logger(strLog, "Created: " & strPath, False)
                        End If
                    Else
                        Call Logger(strLog, "Verification Failed, Folder Doesn't Exist - Quitting Script!", False)
                        Wscript.Quit
                    End If
                Else
                    VerifyFileOrDir objFSO.GetParentFolderName(strPath), blnCreate, blnUnicode, strLog 'Recurse Creating Parent Folder
                   VerifyFileOrDir strPath, blnCreate, blnUnicode, strLog 'Recurse Creating Current Folder
               End If
            Else
                'LOG FOLDER EXISTS
                Call Logger(strLog, "Exists: " & strPath, False)
            End If
        Else
            If Not objFSO.FileExists(strPath) Then
                If objFSO.FolderExists(objFSO.GetParentFolderName(strPath)) Then
                    If blnCreate = True Then
                        'Create File In Current Path
                        If blnUnicode = True Then
                            Set objFile = objFSO.CreateTextFile(strPath, True, True)
                            If StrComp(objFSO.GetExtensionName(strPath), "bks", 1) = 0 Then
                                'Default New Selection File to SystemState
                                objFile.Write "SystemState"
                                objFile.Close
                            End If
                            Set objFile = Nothing
                        Else
                            objFSO.CreateTextFile strPath, True
                        End If
                        'LOG CREATING FILE
                        If Err.Number <> 0 Then
                            Err.Clear
                            Call Logger(strLog, "Err Creating: " & strPath, False)
                            Call Logger(strLog, "Verification Failed - Quitting Script!", False)
                            Wscript.Quit
                        Else
                            Call Logger(strLog, "Created: " & strPath, False)
                        End If
                    Else
                        Call Logger(strLog, "Verification Failed, File Doesn't Exist - Quitting Script!", False)
                        Wscript.Quit
                    End If
                Else
                    VerifyFileOrDir objFSO.GetParentFolderName(strPath), blnCreate, blnUnicode, strLog  'Recurse Creating Parent Folder
                   VerifyFileOrDir strPath, blnCreate, blnUnicode, strLog  'Recurse Creating Current Folder
               End If
            Else
                'LOG FILE EXISTS
                Call Logger(strLog, "Exists: " & strPath, False)
            End If
        End If
    Else
        Call Logger(strLog, "Verification Failed, Drive Doesn't Exist - Quitting Script!", False)
        Wscript.Quit
    End If

    On Error Goto 0

End Sub

Private Function GetBackupSelection(strFile)

    On Error Resume Next

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objTextFile: Set objTextFile = objFSO.OpenTextFile(strFile, 1, False, -1)
    Dim strResult: strResult = objTextFile.ReadAll
    objTextFile.Close

    If Err.Number <> 0 Then
        Err.Clear
        strResult = "Error Reading Selection (.bks) File!"
    Else
        If strResult = "" OR IsNull(strResult) Then
            strResult = "Error Backup Selection (.bks) File is Blank!"
        End If
    End If

    GetBackupSelection = strResult

    On Error Goto 0

End Function

Private Sub RunNTBackup(strBackupType, blnBackupOverwrite, strNtBackupExe, strBksFile, strBackupName, strBkfFile, strLog)

    On Error Resume Next

    'Create Objects and Variables
    Dim objShell: Set objShell = WScript.CreateObject("WScript.Shell")
    Dim runCommand

    'Set NT Backup Command 
    If StrComp(strBackupType,"Full",1) = 0 Then
        ' Full Backup Overwrite
        runCommand = strNtBackupExe & " backup " & chr(34) & "@" & strBksFile & chr(34) & " /n " & chr(34) & strBackupName & ".bkf created " & Now() & chr(34) & " /d " & chr(34) & "Set created " & Now() & chr(34) & " /v:yes /r:no /rs:no /hc:off /m normal /j " & chr(34) & strBackupName & chr(34) & " /l:s /f " & chr(34) & strBkfFile & chr(34)
    Elseif StrComp(strBackupType,"Inc",1) = 0 Then
        If blnBackupOverwrite = True Then
            'Incremental Backup Overwrite
            runCommand = strNtBackupExe & " backup " & chr(34) & "@" & strBksFile & chr(34) & " /n " & chr(34) & strBackupName & ".bkf created " & Now() & chr(34) & " /d " & chr(34) & "Set created " & Now() & chr(34) & " /v:yes /r:no /rs:no /hc:off /m incremental /j " & chr(34) & strBackupName & chr(34) & " /l:s /f " & chr(34) & strBkfFile & chr(34)
        Elseif blnBackupOverwrite = False Then
            'Incremental Backup Append
            runCommand = strNtBackupExe & " backup " & chr(34) & "@" & strBksFile & chr(34) & " /a /d " & chr(34) & strBackupName & ".bkf created " & Now() & chr(34) & " /v:yes /r:no /rs:no /hc:off /m incremental /j " & chr(34) & strBackupName & chr(34) & " /l:s /f " & chr(34) & strBkfFile & chr(34)
        Else
            Call Logger(strLog, "Error 'backupOverwrite' variable is not Set to True Or False - Aborting Script!", False)
            Wscript.Quit
        End If
    Else
        Call Logger(strLog, "Error 'backupType' variable is not Set to Full Or Inc - Aborting Script!", False)
        Wscript.Quit
    End If

    'Run NT Backup
    Call Logger(strLog, runCommand, False)
    objShell.Run runCommand, 1, True

    If Err.Number <> 0 Then
        Err.Clear
        Call Logger(strLog, "Error Occurred During NT Backup", False)
    End If

    On Error Goto 0

End Sub

Private Function GetNTBackupResult(strComputer, strStart, strEnd, strLog)

    On Error Goto 0

    'Get Job Status's From Event Viewer (Logs Event 8001 For Each Folder Completed in .bks file)
    'All Jobs logged to Most Recent Log in Default User Profile NTBackup Folder
    Dim objWMIService: Set objWMIService = GetObject("winmgmts:{(Security)}\\" & strComputer & "\root\cimv2")
    Dim colEvents: Set colEvents = objWMIService.ExecQuery("Select * from Win32_NTLogEvent Where Logfile = 'Application' AND EventCode = '8001'")
    Dim objEvent, strRecordDate, strResult: strResult = ""
    Call Logger(strLog, colEvents.Count & " NT Backup Logs Found Wherre EventCode = 8001", False)
    For Each objEvent in colEvents
        strRecordDate = WMIDateStringToDate(objEvent.TimeWritten)
        If DateDiff("S", startTime, strRecordDate) >= 0 AND DateDiff("S", endTime, strRecordDate) <= 0 Then
            Call Logger(strLog, "Time Written: " & strRecordDate & vbCrLf & objEvent.Message, False)
            If InStr(1, objEvent.Message, "error") > 1 Then
                'Error
                If strResult = "" OR null Then
                    strResult = "Error"
                End If
                If StrComp(strResult, "Success", 1) = 0 Then
                    strResult = "Error"
                End If
                If StrComp(strResult, "Warning", 1) = 0 Then
                    strResult = "Error"
                End If
                If StrComp(strResult, "Unknown", 1) = 0 Then
                    strResult = "Error"
                End If
            Elseif InStr(1,objEvent.Message,"warning",1) > 0 Then
                'Warning
                If strResult = "" OR null Then
                    strResult = "Warning"
                End If
                If StrComp(strResult, "Success", 1) = 0 Then
                    strResult = "Warning"
                End If
                If StrComp(strResult, "Unknown", 1) = 0 Then
                    strResult = "Warning"
                End If
            Elseif InStr(1,objEvent.Message,"successfully",1) > 0 Then
                'Success
                If strResult = "" OR null Then
                    strResult = "Success"
                End If
            Else
                'Uknown
                If strResult = "" OR null Then
                    strResult = "Unknown"
                End If
                If StrComp(strResult, "Success", 1) = 0 Then
                    strResult = "Unknown"
                End If
            End If
        End If
    Next

    'Set Return Value
    If strResult = "" or null Then
        strResult = "Unknown"
        Call Logger(strLog, "No Log Files Found Between " & strStart & " to " & strEnd, False)
    End If

    If Err.Number <> 0 Then
        Err.Clear
        strResult = "ERROR"
        Call Logger(strLog, "Error Detected Getting NT Backup Results", False)
    End If

    GetNTBackupResult = strResult

    On Error Goto 0

End Function

' Function Conver WMI Date to String Date
Function WMIDateStringToDate(dtmBootup)
    WMIDateStringToDate = CDate(Mid(dtmBootup, 5, 2) & "/" & _
    Mid(dtmBootup, 7, 2) & "/" & Left(dtmBootup, 4) _
    & " " & Mid (dtmBootup, 9, 2) & ":" & _
    Mid(dtmBootup, 11, 2) & ":" & Mid(dtmBootup, _
    13, 2))
End Function

Private Function GetNTBackupLog(strDir, strStart, strEnd, strLog)

    On Error Resume Next

    'Find Log File with the Latest Time Stamp
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim strResult: strResult = ""
    Dim file, nfile
    Dim objFolder: Set objFolder = objFSO.GetFolder(strDir)
    For Each file In objFolder.Files
        If Right(file.Name, 4) = ".log" Then
            If nfile = "" or nfile = null Then
                Set nfile = file
                strResult = nfile.Path
                Call Logger(strLog, "Original Latest Log: " & nfile.Name & " (" & nfile.DateLastModified & ")", False)
            Else
                If nfile.DateLastModified < file.DateLastModified Then
                    Set nfile = file
                    strResult = nfile.Path
                    Call Logger(strLog, "Later Log: " & nfile.Name & " (" & nfile.DateLastModified & ")", False)
                End If
            End If
        End If
    Next

    If strResult = "" Then     
        Call Logger(strLog, "Error No Log Files Found!", False)
    Else
        Call Logger(strLog, "Latest Log: " & strResult, False)
    End If

    If Err.Number <> 0 Then
        Err.Clear
        Call Logger(strLog, "Error Occured Getting NT Backup Log File!", False)
        strResult = ""
    End If

    GetNTBackupLog = strResult

    On Error Goto 0

End Function

Private Function ReplaceLineBreaks(myStr)

    On Error Resume Next

    myStr = Replace(myStr, vbCrLf, "|")

    ReplaceLineBreaks = myStr

    On Error Goto 0

End Function

Private Sub SendBlatEmail(blatPath, blatProfile, strRecipients, strSubject, strBody, strAttachment, strLog)

    '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
        Call Logger(strLog, "Provided Blat.exe Location Not Found: " & blatPath, False)
        Call Logger(strLog, "Attempt to Locate Blat.exe in Current Directory: " & scriptPath, False)
        If Not objFSO.FileExists(scriptPath & "blat.exe") Then
            Call Logger(strLog, "Default Blat.exe Location Not Found: " & scriptPath & "blat.exe", False)
            Exit Sub
        Else
            blatPath = scriptPath & "blat.exe"
            Call Logger(strLog, "Default Blat.exe Location Found: " & blatPath, False)
        End If
    Else
        Call Logger(strLog, "Provided Blat.exe Location Found: " & scriptPath & "blat.exe", False)
    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 & "," & strLog & chr(34)
        Call Logger(strLog, "Provided Attachment Found: " & strAttachment, False)
    Else
        Call Logger(strLog, "Provided Attachment Not Found: " & strAttachment, False)
        Call Logger(strLog, "Attempt to Locate Attachment in Current Directory: " & scriptPath, False)
        If objFSO.FileExists(scriptPath & strAttachment) Then
            commandText = commandText & " -attach " & chr(34) & scriptPath & strAttachment & "," & strLog & chr(34)
            Call Logger(strLog, "Default Attachment Found: " & scriptPath & strAttachment, False)
        Else
            Call Logger(strLog, "Default Attachment Not Found: " & scriptPath & strAttachment, False)
            commandText = commandText & " -attach " & chr(34) & strLog & chr(34)
        End If
    End If

    'Send Blat Email
    Call Logger(strLog, "Email Results: " & commandText, False)
    objShell.run commandText, True

    Set objFSO = Nothing
    Set objShell = Nothing

    If Err.Number <> 0 Then
        Err.Clear
        Call Logger(strLog, "Error Occurred Emailing Results!", False)
    End If

    On Error Goto 0

End Sub

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