Бэкап для бд 1с

'Установка переменных
WhatToBackup = "D:\1CBases\Buhgalters_new\*"
BackupPath = "E:\BackUp\" ' символ "\" в конце обязателен.
ArchiveName = "1c_buh" ' наименование итогового файла с архивом
ArchiveParams = "-ssw -r -x!*.cdx -x!*.exe -x!*.zip -mx1" ' параметры для архиватора. Исключения, уровень сжатия и прочее
Threshold = 20 ' кол-во дней, после которых бэкапы будут удаляться.
mailGroup = "Ex.List.BackUpNotification" ' группа в AD, членам которой будут отсылаться сообщения этого скрипта.

'Создание необходимых объектов
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
Set ObjMessage = CreateObject("CDO.Message")
Set WshNetwork = CreateObject("WScript.Network")

' This section provides the configuration information for the remote SMTP server.
objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 
objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "ваш почтовый сервер"
objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 
objMessage.BodyPart.Charset = "windows-1251"

MonthArray = Array("January","February","March","April","May","June","July","August","September","October","November","December")
mailToString = ""
objMessage.Subject = "Backup Script Error"
objMessage.From = "Адрес@от_кого.отправлять"

' Пошла работа скрипта
sProgramFiles = WshShell.ExpandEnvironmentStrings("%programfiles%")

If FSO.FileExists (sProgramFiles & "\7-zip\7z.exe") = false then
	Call getMailAddresses(mailGroup)
	objMessage.To = mailToString
	objMessage.TextBody = "На сервере " & WshNetwork.ComputerName & _
	" не найден архиватор 7-Zip. Запуск бэкапа не возможен."
	objMessage.Configuration.Fields.Update
	objMessage.Send
	Wscript.Quit
End If
If FSO.FolderExists (backupPath) = false Then
	Call getMailAddresses(mailGroup)
	objMessage.To = mailToString
	objMessage.TextBody = "В скрипте для бэкапа " & Wscript.ScriptFullName & " на сервере " & _
	WshNetwork.ComputerName & " целевой путь указан не верно. Он не существует."
	objMessage.Configuration.Fields.Update
	objMessage.Send
	Wscript.Quit
End If
CurrentYear = Cint(Year(Date))
CurrentMonth = Cint(Month(Date))
CurrentDay = Cint(Day(Date))

Call IsYearFolderExists(CurrentYear) ' проверка на существование папки с годом.
Call IsMonthFolderExists(CurrentMonth) ' проверка на существование папки с месяцем
Call IsDayFolderExists(CurrentDay) ' проверка на существование папки с днем месяца

ResultFolder = Cstr(BackupPath & CurrentYear & "\" & MonthArray(CurrentMonth - 1) & "\" & CurrentDay & "\")
retCode = WshShell.Run ("""" & sProgramFiles & "\7-Zip\7z.exe" & """" & " a " & """" & ResultFolder & _
ArchiveName & """" & " " & ArchiveParams & " " & """" & WhatToBackup & """", 1, 1)

If retCode = "0" Then
	'backup was successful
	Call RemoveOldBackups(BackupPath) ' удаление старых бэкапов.	
Else
	Call getMailAddresses(mailGroup)
	objMessage.To = mailToString
	objMessage.TextBody = "На сервере " & WshNetwork.ComputerName & " процедура бэкапа " & _
	Wscript.ScriptFullName & " закончилась ошибкой. Код возврата архиватора: " & retCode
	objMessage.Configuration.Fields.Update
	objMessage.Send
	Wscript.Quit
End If

' Процедура проверки на наличие папки года.
Sub IsYearFolderExists(YearPrm)
	If FSO.FolderExists(BackupPath & YearPrm) = True Then
		' Folder Exists, do nothing
	Else
		FSO.CreateFolder Cstr(BackupPath & YearPrm)
	End If
End Sub

' Процедура проверки на наличие папки месяца
Sub IsMonthFolderExists(MonthPrm)
	If FSO.FolderExists(BackupPath & CurrentYear & "\" & MonthArray(MonthPrm - 1)) = True Then
		' Folder Exists, do nothing
	Else
		FSO.CreateFolder Cstr(BackupPath & CurrentYear & "\" & MonthArray(MonthPrm - 1))
	End If
End Sub

' Процедура проверки на наличие папки даты
Sub IsDayFolderExists(DayPrm)
	If FSO.FolderExists(BackupPath & CurrentYear & "\" & MonthArray(CurrentMonth - 1) & "\" & DayPrm) = True Then
		' Folder Exists, do nothing
	Else
		FSO.CreateFolder Cstr(BackupPath & CurrentYear & "\" & MonthArray(CurrentMonth - 1) & "\" & DayPrm)
	End If
End Sub

' Процедура удаления старых бэкапов.
Sub RemoveOldBackups(rootPath)
	Dim Folder, element, currDate, foldCrDate, dateDifference
	
	currDate = Date
	Set Folder = FSO.GetFolder(rootPath)
	If Folder.SubFolders.Count > 0 Then 'есть подпапки
		For Each element in Folder.SubFolders
			Call RemoveOldBackups(element.Path)
		Next
	Else
		foldCrDate = DateValue(Folder.DateCreated)
		dateDifference = DateDiff("d", foldCrDate, currDate) 'разница в днях между сегодня и созданием папки
		If dateDifference > Threshold Then
			Folder.Delete(1)
		End If
	End If
End Sub

Sub getMailAddresses (groupName2) ' procedure will get mail addresses from group members and add them to mailToString variable
	Dim objGroup

	Set objGroup = GetObject(getGroupDN(groupName2))
	For each objMember in objGroup.Members
		If objMember.class = "user" and objMember.Mail <> "" Then
			mailToString = mailToString & objMember.Mail & ";"
		ElseIf objMember.class = "group" Then
			Call getMailAddresses (objMember.CN)
		End If
	Next
End Sub

Function getGroupDN (groupName1) ' function will return DN of a given group
	Dim rootDSE, domainContainer, conn, rs1, ldapStrUsers, foundObject

	Set rootDSE=GetObject("LDAP://RootDSE")
	domainContainer = rootDSE.Get("defaultNamingContext")
	Set conn = CreateObject("ADODB.Connection")
	conn.Provider = "ADSDSOObject"
	conn.Open "ADs Provider"
	ldapStrUsers = "<GC://" & domainContainer & ">;(&(&(& (cn=" & groupName1 & _
	") (| (&(objectCategory=*)(objectClass=*)) ))));adspath;subtree"
	Set rs1 = conn.Execute(ldapStrUsers)
	
	While Not rs1.EOF
		Set foundObject = GetObject (rs1.Fields(0).Value)
		getGroupDN = "LDAP://" & foundObject.distinguishedName
		rs1.MoveNext
	Wend
End Function