'=========================================================================
' 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