Цитата:
08 что ? винда или скуль ?
винда
» backup базы 1С
Цитата:
винда
1с 8.2, linux centos, файловый вариант: какой способ самый простой, но достаточно эффективный, выгрузка или тупое копирование или есть ещё какие-то?
Можно ли автоматически организовать выгрузку базы с сервера (SQL), чтобы затем развернуть на локальном компьютере в DBF (не backup) ? 1С 7.7.
Пакетный режим работы конфигуратора:
http://www.softpoint.ru/article_id75.htm
+ шедулер какой-нить (xStarter, например)
http://www.softpoint.ru/article_id75.htm
+ шедулер какой-нить (xStarter, например)
G00DVVIN
Спасибо.
Спасибо.
А средствами sql сервера не судьба делать бэкапы: http://1cexpo.ru/administrirovanie/54-strategiya-rezervnogo-kopirovaniya-bazy-dannyx-dlya-ms-sql-server.html
2 artemv
Цитата:
Всё великолепно работает. Спасибо.
Цитата:
"C:\Program Files\1cv81\bin\1cv8.exe" config /S server\namebases /n admin /p password /DumpIB E:\backup\bases\day_%date:~0,10%.dt /Out E:\backup\bases\log\day_%date:~0,10%.txt config
Всё великолепно работает. Спасибо.
Цитата:
"C:\Program Files\1cv81\bin\1cv8.exe" config /S server\namebases /n admin /p password /DumpIB E:\backup\bases\day_%date:~0,10%.dt /Out E:\backup\bases\log\day_%date:~0,10%.txt config
почему то не работает для 8.2... (естественно, путь к программе другой прописываю)
p.s. я не могу понять "namebases" это название открываемой базы?
а вот так работает:
"C:\Program Files\1cv82\8.2.14.519\bin\1cv8.exe" config /F"путь к базе" /N"admin" /P"password" /DumpIB D:\backup\bases\day_%date:~0,10%.dt /Out D:\backup\bases\log\day_%date:~0,10%.txt config
Cпасибо за скрипты! (второй в соседней теме был - http://forum.ru-board.com/topic.cgi?forum=8&topic=42906#1)
Цитата:
"C:\Program Files\1cv82\8.2.14.519\bin\1cv8.exe" config /F"путь к базе" /N"admin" /P"password" /DumpIB D:\backup\bases\day_%date:~0,10%.dt /Out D:\backup\bases\log\day_%date:~0,10%.txt config
А если база не один? Для каждой базы запускать этот скрипт отдельно? У меня база в sql2008.
Проще всего для каждой базы отдельный скрипт или можно в цикле бэкапить полностью все базы, но для этого многое подправить нужно.
Так как этот сайт считаю самым полезным что касается 1С-ки? спешу выложить свое решение именно здесь. В интернете ни чего подобного тому что сделал я не нашел.
Вкратце:
Нужно сделать автоматический бэкап по расписанию в cron 1cv8 в ".dt" - файл при помощи wine C:\Program Files\1cv82\common\1cestart.exe на sql - сервере Postgresql под LINUX
Вся сложность в том что без иксов wineconsole работать не будет, что осложнит его запуск через cron.
Подробно у себя на сайте http://big-town.narod.ru/dt.html
Вкратце:
Нужно сделать автоматический бэкап по расписанию в cron 1cv8 в ".dt" - файл при помощи wine C:\Program Files\1cv82\common\1cestart.exe на sql - сервере Postgresql под LINUX
Вся сложность в том что без иксов wineconsole работать не будет, что осложнит его запуск через cron.
Подробно у себя на сайте http://big-town.narod.ru/dt.html
надо не выгрузку делать, а дамп базы сливать. Как объяснил программер, если будут проблемы какие-то с базой, то выгрузку можно потом и не загрузить. А дамп базы всегда можно развернуть всегда и починить 1с-ку. Тем более дамп выгружается без остановки самой 1с-ки
Код:
set YYYY-MM-DD=%DATE:~6,4%-%DATE:~3,2%-%DATE:~0,2%
set YYYY-MM=%DATE:~6,4%-%DATE:~3,2%
set p_backup=E:\1c-store\%YYYY-MM%
set p_backupnet=\\nas\backup-1c\%YYYY-MM%
set p_rar="C:\Program files\Winrar\rar.exe"
set p_sqlcmd="C:\Program Files\Microsoft SQL Server\100\Tools\Binn\sqlcmd.exe"
set sql_server=somerserver
set sql_username=sa
set sql_userpass=sapassword
IF NOT EXIST %p_backup% MKDIR %p_backup%
IF NOT EXIST %p_backupnet% MKDIR %p_backupnet%
FOR %%i IN (
interstarch
budget
) DO %p_sqlcmd% -S (local) -U "%sql_username%" -P "%sql_userpass%" -d "%%i" -Q "BACKUP DATABASE [%%i] TO DISK = N'%p_backup%\%%i-%YYYY-MM-DD%.backup' WITH INIT , NOUNLOAD , NOSKIP , STATS = 10, NOFORMAT" & %p_rar% a -ep -df %p_backup%\%%i-%YYYY-MM-DD%.rar %p_backup%\%%i-%YYYY-MM-DD%.backup & xcopy /q /h /r /y %p_backup%\%%i-%YYYY-MM-DD%.rar %p_backupnet%\
Код:
set YYYY-MM-DD=%DATE:~6,4%-%DATE:~3,2%-%DATE:~0,2%
set YYYY-MM=%DATE:~6,4%-%DATE:~3,2%
set p_backup=E:\1c-store\%YYYY-MM%
set p_backupnet=\\nas\backup-1c\%YYYY-MM%
set p_rar="C:\Program files\Winrar\rar.exe"
set p_sqlcmd="C:\Program Files\Microsoft SQL Server\100\Tools\Binn\sqlcmd.exe"
set sql_server=somerserver
set sql_username=sa
set sql_userpass=sapassword
IF NOT EXIST %p_backup% MKDIR %p_backup%
IF NOT EXIST %p_backupnet% MKDIR %p_backupnet%
FOR %%i IN (
interstarch
budget
) DO %p_sqlcmd% -S (local) -U "%sql_username%" -P "%sql_userpass%" -d "%%i" -Q "BACKUP DATABASE [%%i] TO DISK = N'%p_backup%\%%i-%YYYY-MM-DD%.backup' WITH INIT , NOUNLOAD , NOSKIP , STATS = 10, NOFORMAT" & %p_rar% a -ep -df %p_backup%\%%i-%YYYY-MM-DD%.rar %p_backup%\%%i-%YYYY-MM-DD%.backup & xcopy /q /h /r /y %p_backup%\%%i-%YYYY-MM-DD%.rar %p_backupnet%\
Уважаемый tankistua, если Ваш пост был адресован мне, то вероятно Вы не прочли мою статью, или хотя бы пост внимательней, там присутствуют слова: Linux,postgresql,wineconsole.
1) Во первых я писал что не приемлю windows+postgresql, а Вы здесь батник выкладываете и к тому же MSSQL!
2) Я не спрашивал каким образом лучше делать бэкап, мне надо именно в dt (), что бы у человека была возможность взять этот файл домой и дома проверить косяки работников.
А бэкап я делаю именно sql-средствами, а конкретно pg_dump. Навсякий ниже приведу скрипт своего бэкапа его прелесть в том что он сам находит все базы в postgresql кроме служебных и делает выгрузку каждой базы в отдельности.
Код:
#!/bin/bash
clear
for DBNAME in `su -c 'psql -tc "select datname from pg_database";' postgres`
do
if [ $DBNAME != "postgres" ] && [ $DBNAME != "template0" ] && [ $DBNAME != "template1" ];
then
FN=/public/arc/sql/`/bin/date +%d%m%y%H%M`
BKNAME=$FN-$DBNAME.gz
echo $BKNAME
/bin/su -c "/usr/bin/pg_dump -F c $DBNAME | /bin/gzip -c > $BKNAME" postgres
fi
done
1) Во первых я писал что не приемлю windows+postgresql, а Вы здесь батник выкладываете и к тому же MSSQL!
2) Я не спрашивал каким образом лучше делать бэкап, мне надо именно в dt (), что бы у человека была возможность взять этот файл домой и дома проверить косяки работников.
А бэкап я делаю именно sql-средствами, а конкретно pg_dump. Навсякий ниже приведу скрипт своего бэкапа его прелесть в том что он сам находит все базы в postgresql кроме служебных и делает выгрузку каждой базы в отдельности.
Код:
#!/bin/bash
clear
for DBNAME in `su -c 'psql -tc "select datname from pg_database";' postgres`
do
if [ $DBNAME != "postgres" ] && [ $DBNAME != "template0" ] && [ $DBNAME != "template1" ];
then
FN=/public/arc/sql/`/bin/date +%d%m%y%H%M`
BKNAME=$FN-$DBNAME.gz
echo $BKNAME
/bin/su -c "/usr/bin/pg_dump -F c $DBNAME | /bin/gzip -c > $BKNAME" postgres
fi
done
Ребят подскажите как вмоём случае сделать бэкап
Есть сервер 1С 8.2
Есть распределённая база 1С на SQL
Как лучше делать бэкапы если постоянно присутствует соединение пользователя под которым работает обмен между распределённой базой?
Есть сервер 1С 8.2
Есть распределённая база 1С на SQL
Как лучше делать бэкапы если постоянно присутствует соединение пользователя под которым работает обмен между распределённой базой?
Ещё есть такая замечательная программа для файловых баз: Бэкапер-1С резервные копии бухгалтерии.
У неё:
* встроенный архиватор 7-Zip
* целостность создаваемых копий
* шифрование
* отправка отчетов на почту
* каталогизация
* архивация документов
И это ещё не всё. К тому же бесплатная.
Смотреть и качать здесь: http://helpme1c.ru/opisanie-dlya-texnicheskix-specialistov-bekaper-1s
У неё:
* встроенный архиватор 7-Zip
* целостность создаваемых копий
* шифрование
* отправка отчетов на почту
* каталогизация
* архивация документов
И это ещё не всё. К тому же бесплатная.
Смотреть и качать здесь: http://helpme1c.ru/opisanie-dlya-texnicheskix-specialistov-bekaper-1s
alexey_karmanov
красивая штучка, бухам однозначно понравится.. :)
если не затруднит, есть пара вопросов:
0. я правильно понимаю, что ваша программа "заточена" только под файловые версии 1С? снято, невнимательно скрины посмотрел..
1. ваша программа умеет бэкапить незаблокированные (использующиеся) базы? т.е. "снапшот" во время работы?
2. если в п.1 - "да", то каким способом блокируется доступ к базе на время создания резервной копии?
3. как реализован автозапуск по выбранным дням - через виндовый шедулер или ставится своя служба?
4. на какое время настроен запуск бэкапа? ну.. на скринах опции времени не увидел..
красивая штучка, бухам однозначно понравится.. :)
если не затруднит, есть пара вопросов:
0. я правильно понимаю, что ваша программа "заточена" только под файловые версии 1С? снято, невнимательно скрины посмотрел..
1. ваша программа умеет бэкапить незаблокированные (использующиеся) базы? т.е. "снапшот" во время работы?
2. если в п.1 - "да", то каким способом блокируется доступ к базе на время создания резервной копии?
3. как реализован автозапуск по выбранным дням - через виндовый шедулер или ставится своя служба?
4. на какое время настроен запуск бэкапа? ну.. на скринах опции времени не увидел..
[more] TheBarmaley
Спасибо =) Программа развивается и дорабатывается по отзывам пользователей.
Да, программа рассчитана прежде всего на обычных пользователей, поэтому все сделано максимально просто и понятно.
0. Все верно, так как поддержка серверных версий усложнит интерфейс программы сильно, а использование серверных 1с для бухгалтерии скорее исключение, чем правило.
1. Если запущена архивация, но база оказалась заблокирована, то это ошибка (и об этом напишется в журнале), но при этом копия будет создана всё-равно, но с пометкой в имени "грязная". Потому что если уж так произошло, то лучше иметь плохую копию, чем не иметь никакую. Конечно, если файлы открыты монопольно, то скопировать не получится никак. Если же нет - то файлы открытые на запись вполне копируются, но только могут быть разсогласованы, поэтому такая копия и называется грязной и может содержать ошибки. Более подробно это расписано у меня вот здесь: http://helpme1c.ru/otvety-na-voprosy-po-programme-bekaper-1s-rezervnye-kopii-buxgalterii#dirtycopy
2. Если база уже запущена, то заблокировать её не удастся во время копирования. Но если запуск резервного копирования происходит в штатном режиме и базы в это время закрыты, то в момент начала копирования все файлы из баз открываются с блокировкой только для чтения т.е. другие программы в момент копирования могут только читать, но не писать в базу.
3. Автозапуск по дням реализован так. Если бухгалтер выбрал один из дней, то программа прописывает себя в автозагрузку. И при старте компьютера проверяет нужно ли делать копию в этот день. Если нужно более сложное расписание, такая возможность тоже есть через ключи запуска и планировщик задач. Там все гибко довольно.
4. Ответил в предыдущем пункте. Но более подробно на все эти вопросы опять же можно почитать в предыдущей ссылке.
[/more]
Спасибо =) Программа развивается и дорабатывается по отзывам пользователей.
Да, программа рассчитана прежде всего на обычных пользователей, поэтому все сделано максимально просто и понятно.
0. Все верно, так как поддержка серверных версий усложнит интерфейс программы сильно, а использование серверных 1с для бухгалтерии скорее исключение, чем правило.
1. Если запущена архивация, но база оказалась заблокирована, то это ошибка (и об этом напишется в журнале), но при этом копия будет создана всё-равно, но с пометкой в имени "грязная". Потому что если уж так произошло, то лучше иметь плохую копию, чем не иметь никакую. Конечно, если файлы открыты монопольно, то скопировать не получится никак. Если же нет - то файлы открытые на запись вполне копируются, но только могут быть разсогласованы, поэтому такая копия и называется грязной и может содержать ошибки. Более подробно это расписано у меня вот здесь: http://helpme1c.ru/otvety-na-voprosy-po-programme-bekaper-1s-rezervnye-kopii-buxgalterii#dirtycopy
2. Если база уже запущена, то заблокировать её не удастся во время копирования. Но если запуск резервного копирования происходит в штатном режиме и базы в это время закрыты, то в момент начала копирования все файлы из баз открываются с блокировкой только для чтения т.е. другие программы в момент копирования могут только читать, но не писать в базу.
3. Автозапуск по дням реализован так. Если бухгалтер выбрал один из дней, то программа прописывает себя в автозагрузку. И при старте компьютера проверяет нужно ли делать копию в этот день. Если нужно более сложное расписание, такая возможность тоже есть через ключи запуска и планировщик задач. Там все гибко довольно.
4. Ответил в предыдущем пункте. Но более подробно на все эти вопросы опять же можно почитать в предыдущей ссылке.
[/more]
немного переделал под webdav... vbscript - гэ
качнуть:
1C_77_Backup2WebDav.txt
1C_77_Backup2WebDav.vbs
посмотреть с подсветкой кода
Код:
'On Error Resume Next
'1c77_backup_SPV_Ed_method
'файл должен быть в ANSI (ни каких utf-8 и ANSI as UTF-8) хотя может и нет...
'chcp 65001 это utf-8 codepage в терминале см %comspec%
Const UploadUser = "_______" 'логин для WEBDAV
Const UploadPass = "____________" 'пароль для WEBDAV
Const PassForArc = "" 'пароль для архива
Set WshShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDateStart = Date ' Дата старта
strTimeStart = Time ' Время старта
aDate = split(strDateStart, ".")
nDays = 7 ' Количество дней для хранения суточных архивов
nWeeks = 4 ' Количество недель для хранения еженедельных архивов
nMonthes = 4 ' Количество месяцев для хранения ежемесячных архивов
nCountSleep = 180000' 3*60*1000 = 3 минуты!!! Пауза до начала бэкапа и дропа польователей (милисекунды)
' Путь к архивируемой БД
strDataPath = "C:\shkur\tst\tst2\" 'бэкслеш в конце обязателен вроде как
' Шаблон имени создаваемого архивного файла
setLocale(1033) 'en-us 'иначе ни как не победить
wd = WeekdayName(Weekday(Now), True) 'крягозябры в имени файла
setLocale(1049) 'ru 'на сервере webdav
strDataDailyFileName = "1c_" & aDate(2) & "-" & aDate(1) & "-" & aDate(0) & "_" & wd
' Локальный ресурс для хранения архивов
strPathArchiveLocal = "C:\shkur\tst\arhiv\"
' Сетевой ресурс для хранения архивов
strPathArchiveRemote = "https://__________.webdav.hidrive.strato.com/users/_________/1C_77Backup/"
strDirDaily = "ArcDaily\" ' Cуточный
strDirWeekly = "ArcWeekly\" ' Недельный
strDirMonthly = "ArcMonthly\" ' Месячный
' Шаблон имени лог-файла
strLogFile = strPathArchiveLocal & strDataDailyFileName & ".log"
' Лог-файл ошибок архиватора
strArcErrLogFile = strPathArchiveLocal & "rar.log"
' Путь к директории архиватора
strPathToArchiver = "%ProgramFiles%\WinRar\"
' Файл-список исключений для архиватора
strExcFile = "ExcFile.txt"
WshShell.Run "net send * Всем выйти в течении 3 минут из 1С!!!"
WScript.Sleep nCountSleep
WshShell.Run "net send * Запущен бэкап 1С. Не входить в 1С пока не будет заключительного сообщения!!!"
If objFSO.FolderExists(strPathArchiveLocal) = False Then objFSO.CreateFolder(strPathArchiveLocal)
' это править для WEBDAV If objFSO.FolderExists(strPathArchiveRemote) = False Then objFSO.CreateFolder(strPathArchiveRemote)
webDavMakeFolder(strPathArchiveRemote)
If objFSO.FileExists(strLogFile) Then objFSO.DeleteFile(strLogFile)
WriteTextFiles Now & " Старт скрипта: " & WScript.ScriptFullName , strLogFile'& VbCrLf
'================================================================================
' Завершение существующих терминальных сессий пользователей перед архивированием
'================================================================================
WriteTextFiles Now & " Завершение cуществующих терминальных сессий"&vbcrlf, strLogFile
WshShell.Run "%comspec% /u /c chcp 65001 & quser >>" & strLogFile, 0, True
'WriteTextFiles VbCrLf&"строка61", strLogFile
WshShell.Run "%comspec% /u /c chcp 65001 & for /f ""eol=; tokens=1 skip=2"" %i in ('quser') do qprocess %i >>" & strLogFile, 0, True
WshShell.Run "%comspec% /u /c chcp 65001 & for /f ""eol=; tokens=2 skip=1"" %i in ('quser') do if /i not ""%i""==""console"" logoff %i /v >>" & strLogFile, 0, True
WriteTextFiles vbcrlf & Now & " Проверка наличия незавершившихся терминальных сессий"&vbcrlf, strLogFile
WshShell.Run "%comspec% /u /c chcp 65001 & quser >>" & strLogFile, 0, True
'WriteTextFiles VbCrLf, strLogFile
'==================================
' Архивация баз за прошедшие сутки
'==================================
WriteTextFiles vbcrlf&Now & " Создание списка исключений для архиватора: " & strExcFile, strLogFile
WriteTextFiles "*.cdx", strExcFile
WriteTextFiles Now & " Cуточная архивация баз " & strDataPath & " ===> " & strPathArchiveLocal & strDirDaily, strLogFile 'strSubject более нигде не используется ?
If objFSO.FolderExists(strPathArchiveLocal & strDirDaily) = False Then objFSO.CreateFolder(strPathArchiveLocal & strDirDaily)
' Вычисление размера архивируемой директории
Set objFolder = objFSO.GetFolder(strDataPath)
WriteTextFiles vbTab&vbTab&" "& " Размер архивируемой директории: " & strDataPath & " - " & Round(objFolder.Size / 1048576,2) & " Mb", strLogFile
' Запуск программы-архиватора
if PassForArc <> "" then
WshShell.Run "%comspec% /a /c echo &" & chr(34) & strPathToArchiver & "Rar.exe" & chr(34) & " a -ep1 -r -se -rr10p -m5 -dh -hp"&PassForArc&" -x@" & strExcFile & " -ilog:" & strArcErrLogFile & " " & strPathArchiveLocal & strDirDaily & strDataDailyFileName & " " & strDataPath & "*", 0, True
else
WshShell.Run "%comspec% /a /c echo &" & chr(34) & strPathToArchiver & "Rar.exe" & chr(34) & " a -ep1 -r -se -rr10p -m5 -dh -x@" & strExcFile & " -ilog:" & strArcErrLogFile & " " & strPathArchiveLocal & strDirDaily & strDataDailyFileName & " " & strDataPath & "*", 0, True
end if
' Вычисление размера созданного архива
If objFSO.FileExists(strPathArchiveLocal & strDirDaily & strDataDailyFileName & ".rar") = true Then
Set objTestFile = objFSO.GetFile(strPathArchiveLocal & strDirDaily & strDataDailyFileName & ".rar")
WriteTextFiles vbTab&vbTab&" "& " Размер созданного суточного архива: " & objTestFile & " - " & Round(objTestFile.Size / 1048576,2) & " Mb", strLogFile
Else
WriteTextFiles vbTab&vbTab&" "& " ОШИБКА: Файл: " & strPathArchiveLocal & strDirDaily & strDataDailyFileName & ".rar не создан", strLogFile
If objFSO.FileExists(strExcFile) Then objFSO.DeleteFile(strExcFile)
objFSO.MoveFile strLogFile, strLogFile & ".err"
WScript.Quit
End If
If objFSO.FileExists(strExcFile) Then objFSO.DeleteFile(strExcFile)
'=======================================
' Копирование архива за прошедшие сутки
'=======================================
' На сетевой ресурс
'strReturn = CopyNewArcFiles (strPathArchiveLocal & strDirDaily, strPathArchiveRemote & strDirDaily)
'strReturn = sendFile2webdav (strPathArchiveLocal & strDirDaily & strDataDailyFileName & ".rar", strPathArchiveRemote & strDirDaily)
strReturn = sendFolder2webdav (strPathArchiveLocal & strDirDaily , strPathArchiveRemote & strDirDaily)
'WriteTextFiles strReturn, strLogFile
' Удаление неактуальных суточных архивов
WriteTextFiles Now & " Удаление архивов старше " & nDays & " суток", strLogFile
' На локальном диске
strReturn = DeleteOldFiles (nDays, strPathArchiveLocal & strDirDaily, "d")
WriteTextFiles strReturn, strLogFile
' На сетевом ресурсе
'strReturn = DeleteOldFiles (nDays, strPathArchiveRemote & strDirDaily, "d")
strReturn = webDavDeleteOldFiles(nDays, strPathArchiveRemote & strDirDaily, "d")
WriteTextFiles strReturn, strLogFile
'========================================
' Копирование архива за прошедшую неделю
'========================================
If WeekDay(strDateStart, 2) = 1 Then
' На локальный диск
strReturn = CopyNewArcFiles (strPathArchiveLocal & strDirDaily, strPathArchiveLocal & strDirWeekly)
WriteTextFiles strReturn, strLogFile
' На сетевой ресурс
'strReturn = CopyNewArcFiles (strPathArchiveRemote & strDirDaily, strPathArchiveRemote & strDirWeekly)
strReturn = WebDavDoCopyMove (strPathArchiveRemote & strDirDaily, strPathArchiveRemote & strDirWeekly, true)
WriteTextFiles strReturn, strLogFile
' Удаление неактуальных недельных архивов
WriteTextFiles Now & " Удаление архивов старше " & nWeeks & " недель", strLogFile
' На локальном диске
strReturn = DeleteOldFiles (nWeeks, strPathArchiveLocal & strDirWeekly, "ww")
WriteTextFiles strReturn, strLogFile
' На сетевом ресурсе
'strReturn = DeleteOldFiles (nWeeks, strPathArchiveRemote & strDirWeekly, "ww")
strReturn = webDavDeleteOldFiles (nWeeks, strPathArchiveRemote & strDirWeekly, "ww")
WriteTextFiles strReturn, strLogFile
End If
'=======================================
' Копирование архива за прошедший месяц
'=======================================
If Day(strDateStart) = 1 Or _
((Day(strDateStart) = 2 Or Day(strDateStart) = 3) And WeekDay(strDateStart, 2) = 1) Then
' На локальный диск
strReturn = CopyNewArcFiles (strPathArchiveLocal & strDirDaily, strPathArchiveLocal & strDirMonthly)
WriteTextFiles strReturn, strLogFile
' На сетевой ресурс
'strReturn = CopyNewArcFiles (strPathArchiveRemote & strDirDaily, strPathArchiveRemote & strDirMonthly)
strReturn = WebDavDoCopyMove (strPathArchiveRemote & strDirDaily, strPathArchiveRemote & strDirMonthly, true)
WriteTextFiles strReturn, strLogFile
' Удаление неактуальных месячных архивов
WriteTextFiles Now & " Удаление архивов старше " & nMonthes & " месяцев", strLogFile
' На локальном диске
strReturn = DeleteOldFiles (nMonthes, strPathArchiveLocal & strDirMonthly, "m")
WriteTextFiles strReturn, strLogFile
' На сетевом ресурсе
strReturn = webDavDeleteOldFiles (nMonthes, strPathArchiveRemote & strDirMonthly, "m")
WriteTextFiles strReturn, strLogFile
End If
'==============================================
' Функция копирования файлов созданных архивов
'==============================================
Function CopyNewArcFiles (strPathSrc, strPathDst)
strCopyLog = Now & " копирование созданного суточного архива" &vbcrlf
If objFSO.FolderExists(strPathDst) = False Then objFSO.CreateFolder(strPathDst)
objFSO.CopyFile strPathSrc & strDataDailyFileName & ".rar", strPathDst, True
If objFSO.FileExists(strPathDst & strDataDailyFileName & ".rar") = true Then
Set objTestFile = objFSO.GetFile(strPathDst & strDataDailyFileName & ".rar")
strCopyLog = strCopyLog & Now & " Файл: " & strDataDailyFileName & ".rar" & " скопирован в " & strPathDst
Else
strCopyLog = strCopyLog & Now & " ОШИБКА: Файл: " & strDataDailyFileName & ".rar" & " не скопирован в " & strPathDst
End If
CopyNewArcFiles = strCopyLog
End Function
'==============================================
' Функция удаления файлов неактуальных архивов
'==============================================
Function DeleteOldFiles (strPeriod, strPath, intrvl)
Set objFolder = objFSO.GetFolder(strPath)
Set objFiles = objFolder.Files
For Each File In objFiles
Result = Abs(DateDiff(intrvl, Now, File.DateCreated))
If Result > strPeriod-1 Then
strDeleteLog = strDeleteLog + vbTab & "Удален файл: " & File.Path & " от: " & File.DateCreated & VbCrLf
File.Delete
End If
Next
DeleteOldFiles = strDeleteLog
End Function
WriteTextFiles Now & " Архивация окончена. Время выполнения архивации: " & CDate(Time - strTimeStart), strLogFile
WriteTextFiles Now & " terminating...", strLogFile
'=======================
' Копирование лог-файла
'=======================
' Ежедневный
If objFSO.FileExists(strLogFile) Then
objFSO.CopyFile strLogFile, strPathArchiveLocal & strDirDaily, True
'objFSO.CopyFile strLogFile, strPathArchiveRemote & strDirDaily, True
sendFile2webdav strLogFile, strPathArchiveRemote & strDirDaily
' Еженедельный
If WeekDay(strDateStart, 2) = 1 Then
If objFSO.FileExists(strLogFile) Then
objFSO.CopyFile strLogFile, strPathArchiveLocal & strDirWeekly, True
'objFSO.CopyFile strLogFile, strPathArchiveRemote & strDirWeekly, True
sendFile2webdav strLogFile, strPathArchiveRemote & strDirWeekly
End If
End If
' Ежемесячный
If Day(strDateStart) = 1 Or _
((Day(strDateStart) = 2 Or Day(strDateStart) = 3) And WeekDay(strDateStart, 2) = 1) Then
If objFSO.FileExists(strLogFile) Then
objFSO.CopyFile strLogFile, strPathArchiveLocal & strDirMonthly, True
'objFSO.CopyFile strLogFile, strPathArchiveRemote & strDirMonthly, True
sendFile2webdav strLogFile, strPathArchiveRemote & strDirMonthly
End If
End If
' Удаление временного лога
objFSO.DeleteFile(strLogFile)
End If
Set WshShell = Nothing
Set objFSO = Nothing
WScript.Quit
Sub WriteTextFiles (strText, strPath)
'===================================
' Процедура записи текстового файла
'===================================
Set objFile = objFSO.OpenTextFile(strPath, 8, True)
objFile.WriteLine(strText)
objFile.Close
End Sub
Sub WriteTextFilesStandalone (strText, strPath)
Set objFile = CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 8, True)
objFile.WriteLine(strText)
objFile.Close
Set objFile = Nothing
End Sub
function isFolderExist(strDest)
'проверяет существует ли папка
'возвращает true если папка существует и false если нет
'msgbox "isFolderExist = "&isFolderExist(baseURI & "ssa\")
Dim XMLreq
Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
Dim sSourceURL
sSourceURL = backslash2slash(strDest)
XMLreq.open "PROPFIND", sSourceURL, False, UploadUser, UploadPass
XMLreq.setRequestHeader "Content-Type", "text/xml"
XMLreq.setRequestHeader "Depth", 1 'цифру указывать в кавычказ или нет? - пофиг
'XMLreq.setRequestHeader "Translate", "f"
'XMLreq.setRequestHeader "Brief", "t" 'The default setting is "f".
XMLreq.send "<!--?xml version='1.0'?--><d:propfind xmlns:d="DAV:"><d:prop><d:resourcetype></d:resourcetype></d:prop></d:propfind>"
'MsgBox XMLreq.status ' 207 есть 404 нет
'WriteTextFiles XMLreq.responsetext, "XMLreq.responsetext.txt"
'msgbox XMLreq.responseXML.namespaces()
'XMLreq.responseXML.setProperty "SelectionNamespaces", "xmlns:ms='urn:schemas-microsoft-com:xslt'"
'msgbox "SelectionNamespaces " & XMLreq.responseXML.getProperty("SelectionNamespaces")
'msgbox "getProperty1 " & XMLreq.responseXML.getProperty[0]
'msgbox XMLreq.responseXML.DocumentElement.GetPrefixOfNamespace("DAV:")
'Dim Node : Set Node = XMLreq.responseXML '.DocumentElement.selectSingleNode("multistatus")
'set Node = XMLreq.responseXML ' selectSingleNode("response")
'Node.setProperty "SelectionLanguage", "XPath"
'msgbox Node.getProperty("SelectionLanguage")
'ns = "xmlns:D='DAV:' "
'Node.SetProperty "SelectionNamespaces", ns
'msgbox Node.getProperty("SelectionNamespaces")
'MsgBox Node.selectSingleNode("href")
'MsgBox Node.selectNodes("multistatus", nsmgr) '.nodeName &" "& Node.text
'XMLreq.responseXML.selectSingleNode("status") ' &" "& Node.text
strStatus = XMLreq.status
if strStatus = "207" then
isFolderExist = true
elseif strStatus = "404" then
isFolderExist = false
else isFolderExist = "isFolderExist function says: wrong status from server. XMLreq.status = "&XMLreq.status &" "& XMLreq.statusText
end if
'MsgBox XMLreq.responseXML.getElementsByTagName("D:status").nextNode.Text 'HTTP/1.1 200 OK 'ничего не возвращает если ответ 404
'Dim objNodeList
'Dim msg
'Set objNodeList = XMLreq.responseXML.getElementsByTagName("D:status")
'For i = 0 TO (objNodeList.length -1)
' Set objNode = objNodeList.nextNode
' msg = msg & "x " & objNode.NamespaceURI & " " & objNode.NodeName &" "& objNode.Text & Vbcrlf
'Next
'MsgBox msg
Set XMLreq = Nothing
End function
function isFileExist(strDest)
'проверяет существует ли файл
'возвращает true если файл существует и false если нет
'слеш вконце даёт ошибку
'msgbox isFileExist(baseURI&"WriteTextFilesAppendToLine.vbs")
Dim XMLreq
Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
Dim sSourceURL
sSourceURL = backslash2slash(strDest)
If (Right(sSourceURL,1)) = "/" Then
sSourceURL = Left(sSourceURL, Len(sSourceURL)-1)
Else
sSourceURL = sSourceURL
End If
XMLreq.open "PROPFIND", sSourceURL, False, UploadUser, UploadPass
XMLreq.setRequestHeader "Content-Type", "text/xml"
XMLreq.setRequestHeader "Depth", 1 'цифру указывать в кавычказ или нет? - пофиг
'XMLreq.setRequestHeader "Translate", "f"
'XMLreq.setRequestHeader "Brief", "t" 'The default setting is "f".
XMLreq.send "<!--?xml version='1.0'?--><d:propfind xmlns:d="DAV:"><d:prop><d:resourcetype></d:resourcetype></d:prop></d:propfind>"
strStatus = XMLreq.status
if strStatus = "207" then
isFileExist = true
elseif strStatus = "404" then
isFileExist = false
else isFileExist = "isFileExist function says: wrong status from server. XMLreq.status = "&XMLreq.status &" "& XMLreq.statusText
end if
Set XMLreq = Nothing
End function
function webDavMakeFolder(strUrlFolderToCreate)
'создаёт папку если она не существует
'возвращает true если папка создана и false если нет
'msgbox "webDavMakeFolder = "&webDavMakeFolder(baseURI & "ssasdfgsdfgsdfg")
'может только один уровень создать т.е. если есть папка https://webdav.example.com/user/ то webDavMakeFolder не сможет сделать .../user/folder1/folder2 возвращает статус 409 Conflict
'msgbox webDavMakeFolder(baseURI & "zzz")
if isFolderExist(strUrlFolderToCreate) = false then
Dim XMLreq
Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
Dim sSourceURL
sSourceURL = backslash2slash(strUrlFolderToCreate)
strCopyLog = Now & " создаю папку "& sSourceURL & "..."
XMLreq.open "MKCOL", sSourceURL, False, UploadUser, UploadPass
XMLreq.setRequestHeader "Content-Type", "text/xml"
'XMLreq.setRequestHeader "Content-Length", "XXX"
XMLreq.send
'MsgBox XMLreq.Status
If XMLreq.Status = "201" Or XMLreq.Status = "207" Then
'MsgBox "The folder has been created. Status is " & XMLreq.statusText, vbCritical, "Folder Created!!"
webDavMakeFolder = true
strCopyLog = strCopyLog & "well done."
Elseif XMLreq.Status = "404" then
'Note: Error 405 can mean permissions problem on item already exists.
'MsgBox "The folder has not been created. Status is " & XMLreq.statusText, vbCritical, " Folder not Created!!"
webDavMakeFolder = false
strCopyLog = strCopyLog & "АШЫПКО ДЭТЕКТЕД! Папка не создана."
else
webDavMakeFolder = "webDavMakeFolder function says: wrong status from server. XMLreq.status = "&XMLreq.status &" "& XMLreq.statusText
strCopyLog = strCopyLog & "АШЫПКО ДЭТЕКТЕД! Папка не создана. webDavMakeFolder function says: wrong status from server. XMLreq.status = "&XMLreq.status &" "& XMLreq.statusText
End If
Set XMLreq = Nothing
else
webDavMakeFolder = "folder already created"
end if
WriteTextFiles strCopyLog, strLogFile
End function
function webDavDeleteFolder(strUrlFolderToDelete)
'webDavDeleteFolder(baseURI & "ssb") 'для папки слеш вконце обязателен
'может удалить только последний уровень т.е. если есть папка https://webdav.example.com/user/folder1/folder2/ то webDavDeleteFolder если путь: .../user/folder1/folder2 возвращает статус 204 и удаляет только последнюю папку (folder2), если папки нет то возваращает 404.
'если есть папка .../folder1/folder2/ а команда на удаление .../folder1/ то удалит рекурсивно вместе с файлами
'если есть папка .../folder1/ а команда на удаление .../folder1/folder2/ то ни чего не удалит
'как оказалось файл нельзя удалять со слешем вконце. но это было поправлено -> см webDavDeleteFile
'msgbox webDavDeleteFolder(baseURI & "/folder1/folder2/")
'msgbox strUrlFolderToDelete
Dim XMLreq : Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
Dim sSourceURL : sSourceURL = backslash2slash(strUrlFolderToDelete)
strCopyLog = Now & " удаляю папку "& sSourceURL & "..."
'msgbox sSourceURL
XMLreq.open "DELETE", sSourceURL, False, UploadUser, UploadPass
XMLreq.setRequestHeader "Content-Type", "text/xml"
'XMLreq.setRequestHeader "Content-Length", "XXX"
XMLreq.send
'webDavDeleteFolder = XMLreq.Status 'при удалении папки код 204, и 404 если не найдено
If XMLreq.Status = "204" Then
'MsgBox "The folder has been created. Status is " & XMLreq.statusText, vbCritical, "Folder Created!!"
webDavDeleteFolder = true
strCopyLog = strCopyLog & " удалено."
Elseif XMLreq.Status = "404" Then
webDavDeleteFolder = false
strCopyLog = strCopyLog & " НЕ удалено."
'Note: Error 405 can mean permissions problem on item already exists.
'MsgBox "The folder has not been created. Status is " & XMLreq.statusText, vbCritical, " Folder not Created!!"
Else
webDavDeleteFolder = "webDavDeleteFolder say's: something goes wrong - XMLreq.Status = "&XMLreq.Status &" "& XMLreq.StatusText
strCopyLog = strCopyLog & " НЕ удалено! АШЫПКО ДЭТЕКТЕД! webDavDeleteFolder say's: something goes wrong - XMLreq.Status = "&XMLreq.Status &" "& XMLreq.StatusText
End If
Set XMLreq = nothing
WriteTextFiles strCopyLog, strLogFile
End function
function webDavDeleteFile(strUrlFileToDelete)
'удаляет файл возвращает true или false
'msgbox strUrlFileToDelete
Dim XMLreq : Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
Dim sSourceURL : SourceURL = backslash2slash(strUrlFileToDelete)
If (Right(sSourceURL,1)) = "/" Then
sSourceURL = Left(sSourceURL, Len(sSourceURL)-1)
Else
sSourceURL = sSourceURL
End If
strCopyLog = Now & " удаляю файл "& sSourceURL & "..."
'msgbox sSourceURL
XMLreq.open "DELETE", sSourceURL, False, UploadUser, UploadPass
XMLreq.setRequestHeader "Content-Type", "text/xml"
'XMLreq.setRequestHeader "Content-Length", "XXX"
XMLreq.send
'webDavDeleteFile = XMLreq.Status 'при удалении папки код 204, и 404 если не найдено
If XMLreq.Status = "204" Then
'MsgBox "The folder has been created. Status is " & XMLreq.statusText, vbCritical, "Folder Created!!"
webDavDeleteFile = true
strCopyLog = strCopyLog & " файл был удален."
Elseif XMLreq.Status = "404" Then
webDavDeleteFile = false
strCopyLog = strCopyLog & " файл НЕ был удален."
'Note: Error 405 can mean permissions problem on item already exists.
'MsgBox "The folder has not been created. Status is " & XMLreq.statusText, vbCritical, " Folder not Created!!"
Else
webDavDeleteFile = "webDavDeleteFile say's: something goes wrong - XMLreq.Status = "&XMLreq.Status &" "& XMLreq.StatusText
strCopyLog = strCopyLog & " файл НЕ был удален. АШЫПКО ДЭТЕКТЕД! webDavDeleteFile say's: something goes wrong - XMLreq.Status = "&XMLreq.Status &" "& XMLreq.StatusText
End If
Set XMLreq = nothing
WriteTextFiles strCopyLog, strLogFile
End function
function sendFile2webdav (strUploadFilePath, strUrlUploadDestWithoutFilename)
'baseURI without filename
'msgbox sendFile2webdav ("C:\shkur\WriteTextFilesAppendToLine.txt", baseURI)
UploadType = "binary"
strUrlUploadDestWithoutFilename = backslash2slash(strUrlUploadDestWithoutFilename) 'чтобы точно был слеш вконце
strCopyLog = Now & " копирую файл от сюда "& strUploadFilePath& " сюда " &strUrlUploadDestWithoutFilename &"..."&vbcrlf
if isFolderExist(strUrlUploadDestWithoutFilename) = false then webDavMakeFolder(strUrlUploadDestWithoutFilename)
'msgbox "strUploadFilePath = "&strUploadFilePath & vbcrlf& "strUrlUploadDestWithoutFilename = "&strUrlUploadDestWithoutFilename 'Vbcrlf
sfileName= mid(strUploadFilePath, InstrRev(strUploadFilePath,"\")+1,len(strUploadFilePath))
'strURL = strUrlUploadDestWithoutFilename & "/" & strUploadFilePath
'strURL = strUrlUploadDestWithoutFilename & "/" & sfileName
dim strURL : strURL = strUrlUploadDestWithoutFilename & sfileName
if isFileExist(strURL) = false then
sData = getFileBytes(strUploadFilePath, UploadType)
dim xmlhttp : set xmlhttp=createobject("MSXML2.XMLHTTP.3.0")
'msgbox "Upload-URL: " & strURL
xmlhttp.Open "PUT", strURL, false, UploadUser, UploadPass
xmlhttp.Send sData
'Wscript.Echo "Upload-Status: " & xmlhttp.statusText & " " & xmlhttp.status
'sendFile2webdav
If (xmlhttp.status >= 200 And xmlhttp.status < 300) Then
'wscript.echo "PUT: Success! " & "Results = " & xmlhttp.status & ": " & xmlhttp.statusText
sendFile2webdav = True
strCopyLog = strCopyLog & Now & " Файл: " & sfileName & " скопирован в " & strUrlUploadDestWithoutFilename
ElseIf xmlhttp.status = 401 Then
'wscript.echo "PUT: You don't have permission to do the job! Please check your permissions on this item."
sendFile2webdav = False
strCopyLog = strCopyLog & Now & " ОШИБКА: Файл: " & sfileName & " НЕ скопирован в " & strUrlUploadDestWithoutFilename
Else
'wscript.echo "PUT: Request Failed. Results = " & xmlhttp.status & ": " & xmlhttp.statusText
sendFile2webdav = False
strCopyLog = strCopyLog & Now & " ОШИБКА: Файл: " & sfileName & " НЕ скопирован в " & strUrlUploadDestWithoutFilename & " sendFile2webdav say's: something goes wrong - XMLreq.Status = "&xmlhttp.status &" "& xmlhttp.statusText
End If
set xmlhttp=Nothing
else
sendFile2webdav = False
strCopyLog = strCopyLog & Now & " file "& strURL &" already exists!"
End If
WriteTextFiles strCopyLog, strLogFile
End function
function sendFolder2webdav(strUploadFolderPath, strUrlUploadDestWithoutFilename)
'отправляет папку на webdav
strCopyLog = Now & " отправляю папку "& strUploadFolderPath &" на webdav "& strUrlUploadDestWithoutFilename &"..."
listLocalFiles = listFilesLocalFolder(strUploadFolderPath)
x=1
for each flnm in listLocalFiles
sendFile2webdav strUploadFolderPath & flnm, strUrlUploadDestWithoutFilename
x=x+1
next
strCopyLog = strCopyLog & "отправлено "&x&"файлов."
WriteTextFiles strCopyLog, strLogFile
End function
Function WebDavDoCopyMove(sSourceURL, sDestinationURL, bCopy)
''---------------------------------------------------------------------------------
' WebDavDoCopyMove - Used to move an item from one folder to another in the same store.
' sSourceURL - item being moved/copied
' sDestinationURL - the URL it is going to
' bCopy - TRUE if copying or FALSE if moving
'---------------------------------------------------------------------------------
strCopyLog = Now & " копирую на webdav'е от сюда "& sSourceURL &" сюда "& sDestinationURL & "..." & vbcrlf
Set oXMLHttp = CreateObject("microsoft.xmlhttp") ' = New MSXML2.XMLHTTP30
Dim sVerb
If bCopy = True Then sVerb = "COPY" Else sVerb = "MOVE" End If
If sUser <> "" Then
oXMLHttp.Open sVerb, sSourceURL, False, UploadUser, UploadPass
Else
oXMLHttp.Open sVerb, sSourceURL, False ', sUser, sPassword
End If
oXMLHttp.setRequestHeader "Destination", sDestinationURL
'oXMLHttp.setRequestHeader "Overwrite", "T"
' Send the stream across
oXMLHttp.Send
If (oXMLHttp.Status >= 200 And oXMLHttp.Status < 300) Then
'wscript.echo "Success! " & "Results = " & oXMLHttp.Status & ": " & oXMLHttp.statusText
WebDavDoCopyMove = true
strCopyLog = strCopyLog & Now & " Скопировал от сюда "& sSourceURL &" сюда "& sDestinationURL
ElseIf oXMLHttp.Status = 401 Then
'wscript.echo "You don't have permission to do the job! Please check your permissions on this item."
WebDavDoCopyMove = false
strCopyLog = strCopyLog & Now & " Не получилось скопипастить от сюда "& sSourceURL &" сюда "& sDestinationURL &" т.к. не хватает прав."
Else
'wscript.echo "Request Failed. Results = " & oXMLHttp.Status & ": " & oXMLHttp.statusText
WebDavDoCopyMove = false
strCopyLog = strCopyLog & Now & " АШЫПКО ДЭТЕКТЕД! WebDavDoCopyMove говорит:"& oXMLHttp.Status &" "& oXMLHttp.statusText &" ну что, красноглазый :)"
End If
WriteTextFiles strCopyLog, strLogFile
Set oXMLHttp = Nothing
End Function
function getFileBytes(flnm, sType)
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
if sType="binary" then
objStream.Type = 1 ' adTypeBinary
else
objStream.Type = 2 ' adTypeText
objStream.Charset ="ascii"
end if
objStream.Open
objStream.LoadFromFile flnm
if sType="binary" then
getFileBytes=objStream.Read 'read binary'
else
getFileBytes= objStream.ReadText 'read ascii'
end if
objStream.Close
Set objStream = Nothing
end function
Function webDavDeleteOldFiles (strPeriod, strPath, intrvl)
'webDavDeleteOldFiles 1, strURL, "d"
'strPath - папка без имени файла со слешем вконце
'return log
strPath = backslash2slash(strPath)
strDeleteLog = Now & " удаляю файлы из "& strPath & "..." &vbcrlf
arrListFiles = webDavListOnlyFiles(strPath)
For Each File In arrListFiles
'msgbox File(1)
Result = Abs(DateDiff(intrvl, Now, CDate(Replace(Replace(File(1),"T"," "),"Z"," "))))
'msgbox Result
If Result > strPeriod-1 Then
'msgbox "kukara4a"
wddofRet = webDavDeleteFile(strPath&File(0))
if wddofRet = true then
strDeleteLog = now & " Удален файл: " & File(0) & " от: " & File(1)
elseif wddofRet = false then
strDeleteLog = now & " Файл НЕ удален: " & File(0) & " от: " & File(1)
else
strDeleteLog = now &" "& wddofRet
End If
End If
Next
webDavDeleteOldFiles = strDeleteLog
End Function
'iterate2ndArray(webDavListOnlyFiles(strURL))
'dim ret()
'ret = webDavListOnlyFiles(strURL)
'msgbox ret(1)(0)
'iterate2ndArray(webDavListOnlyFiles(strURL)) 'return 2D-array 1st array is index, second file name, Date
function webDavListOnlyFiles(strURL) 'with trailing slash 'return obj or array?
Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
sSourceURL = backslash2slash(strURL)
XMLreq.open "PROPFIND", sSourceURL, False, "UploadUser", "UploadPass"
XMLreq.setRequestHeader "Content-Type", "text/xml"
XMLreq.setRequestHeader "Depth", 1 'цифру указывать в кавычказ или нет? - пофиг
'XMLreq.setRequestHeader "Translate", "f"
'XMLreq.setRequestHeader "Brief", "t" 'The default setting is "f".
'XMLreq.send "<!--?xml version='1.0'?--><d:propfind xmlns:d="DAV:"><d:allprop></d:allprop></d:propfind>"
XMLreq.send "<!--?xml version='1.0'?--><d:propfind xmlns:d="DAV:"><d:prop><d:resourcetype><d:collection></d:collection></d:resourcetype><d:creationdate></d:creationdate></d:prop></d:propfind>"
'WriteTextFilesStandalone XMLreq.responseText, "C:\shkur\tmpCopy\xml.xml"
'MsgBox XMLreq.responseXML.getElementsByTagName("D:status").nextNode.Text 'HTTP/1.1 200 OK 'ничего не возвращает если ответ 404
Set objNodeList1 = XMLreq.responseXML.getElementsByTagName("D:href")
Set objNodeList2 = XMLreq.responseXML.getElementsByTagName("lp1:creationdate")
dim arr1st()
'dim arr2nd() ' несоответствие типа
''Set arr1st = CreateObject("Scripting.Dictionary")
x=0
For i = 0 TO (objNodeList1.length -1)
''Set arr2nd = CreateObject("Scripting.Dictionary")
Set objNode1 = objNodeList1.nextNode
set objNode2 = objNodeList2.nextNode
If (Right(objNode1.text,1)) <> "/" Then 'trailing slash = folder
flnm = (mid(objNode1.text,(InStrRev(objNode1.text,"/"))+1))
creationdate = CDate(Replace(Replace(objNode2.text,"T"," "),"Z"," "))
'msg = msg & x & ". " & flnm & " "& objNode2.text &" "& Vbcrlf
''arr2nd.Add "flnm", flnm
''arr2nd.Add "creationdate", objNode2.text
arr2nd = array(flnm, creationdate)
ReDim Preserve arr1st(x)
arr1st(x)=arr2nd
x=x+1
''arr1st.Add x, arr2nd
End If
Set arr2nd = Nothing
Next
'MsgBox msg
Set XMLreq = Nothing
webDavListOnlyFiles = arr1st
'iterate2ndArray(arr1st)
'msgbox isarray(arr1st)
'msgbox isarray(arr1st(0))
'Set arr1st = Nothing 'несоответствие типа...
End Function
function listFilesLocalFolder(strPathSrc)
'Set fso = CreateObject("Scripting.FileSystemObject") 'заменить на objFSO
Set files = objFSO.GetFolder(strPathSrc).Files
dim array1st()
x=0
For each folderIdx In files
ReDim Preserve arr1st(x)
arr1st(x) = folderIdx.Name
x=x+1
'msg = msg & folderIdx.Name & vbcrlf
Next
'msgbox msg
listFilesLocalFolder = arr1st
'Set fso = nothing
End function
function backslash2slash(strUrl)
'поменять бекслеши на слеши и добавить слеш вконце
'msgbox backslash2slash("https://www.w3school///s.com/\\\\\vbscript/func_instr.asp")
leftSide = (Left(strUrl,(InStr(strUrl,"://"))+2))
rightSide = (Right(strUrl,(Len(strUrl)-InStr(strUrl,"://")-2)))
rightSide = Replace(Replace(Replace(Replace(rightSide,"\","/"),"///","/"),"//","/"),"//","/")
concat = leftSide&rightSide
If (Right(concat,1)) <> "/" Then
backslash2slash = concat & "/"
Else
backslash2slash = concat
End If
End function
'iterate2ndArray(test())
function test()
b=Array("b1","b2")
c=Array("c1","c2")
d=Array("d1","d2")
f=Array("f1","f2")
'a=Array(b,c,d,f)
dim a(3)
a(0)=b
a(1)=c
a(2)=d
a(3)=f
msgbox isArray(a(0))
test = a
end function
function iterate2ndArray(a)
if isArray(a) = false then
msgbox "это не массив"
else
msg = "begin:"&vbcrlf
for each x in a
'msg = msg & "1st array:"& x
for each xx in x
msg = msg & " " & xx
'msgbox xx
next
msg = msg & vbcrlf
next
msgbox msg
end if
End Function
function iterate1stArray(a)
if isArray(a) = false then
msgbox "это не массив"
else
msg = "begin:"&vbcrlf
for each x in a
msg = msg & " " & x
msg = msg & vbcrlf
next
msgbox msg
end if
End Function
качнуть:
1C_77_Backup2WebDav.txt
1C_77_Backup2WebDav.vbs
посмотреть с подсветкой кода
Код:
'On Error Resume Next
'1c77_backup_SPV_Ed_method
'файл должен быть в ANSI (ни каких utf-8 и ANSI as UTF-8) хотя может и нет...
'chcp 65001 это utf-8 codepage в терминале см %comspec%
Const UploadUser = "_______" 'логин для WEBDAV
Const UploadPass = "____________" 'пароль для WEBDAV
Const PassForArc = "" 'пароль для архива
Set WshShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDateStart = Date ' Дата старта
strTimeStart = Time ' Время старта
aDate = split(strDateStart, ".")
nDays = 7 ' Количество дней для хранения суточных архивов
nWeeks = 4 ' Количество недель для хранения еженедельных архивов
nMonthes = 4 ' Количество месяцев для хранения ежемесячных архивов
nCountSleep = 180000' 3*60*1000 = 3 минуты!!! Пауза до начала бэкапа и дропа польователей (милисекунды)
' Путь к архивируемой БД
strDataPath = "C:\shkur\tst\tst2\" 'бэкслеш в конце обязателен вроде как
' Шаблон имени создаваемого архивного файла
setLocale(1033) 'en-us 'иначе ни как не победить
wd = WeekdayName(Weekday(Now), True) 'крягозябры в имени файла
setLocale(1049) 'ru 'на сервере webdav
strDataDailyFileName = "1c_" & aDate(2) & "-" & aDate(1) & "-" & aDate(0) & "_" & wd
' Локальный ресурс для хранения архивов
strPathArchiveLocal = "C:\shkur\tst\arhiv\"
' Сетевой ресурс для хранения архивов
strPathArchiveRemote = "https://__________.webdav.hidrive.strato.com/users/_________/1C_77Backup/"
strDirDaily = "ArcDaily\" ' Cуточный
strDirWeekly = "ArcWeekly\" ' Недельный
strDirMonthly = "ArcMonthly\" ' Месячный
' Шаблон имени лог-файла
strLogFile = strPathArchiveLocal & strDataDailyFileName & ".log"
' Лог-файл ошибок архиватора
strArcErrLogFile = strPathArchiveLocal & "rar.log"
' Путь к директории архиватора
strPathToArchiver = "%ProgramFiles%\WinRar\"
' Файл-список исключений для архиватора
strExcFile = "ExcFile.txt"
WshShell.Run "net send * Всем выйти в течении 3 минут из 1С!!!"
WScript.Sleep nCountSleep
WshShell.Run "net send * Запущен бэкап 1С. Не входить в 1С пока не будет заключительного сообщения!!!"
If objFSO.FolderExists(strPathArchiveLocal) = False Then objFSO.CreateFolder(strPathArchiveLocal)
' это править для WEBDAV If objFSO.FolderExists(strPathArchiveRemote) = False Then objFSO.CreateFolder(strPathArchiveRemote)
webDavMakeFolder(strPathArchiveRemote)
If objFSO.FileExists(strLogFile) Then objFSO.DeleteFile(strLogFile)
WriteTextFiles Now & " Старт скрипта: " & WScript.ScriptFullName , strLogFile'& VbCrLf
'================================================================================
' Завершение существующих терминальных сессий пользователей перед архивированием
'================================================================================
WriteTextFiles Now & " Завершение cуществующих терминальных сессий"&vbcrlf, strLogFile
WshShell.Run "%comspec% /u /c chcp 65001 & quser >>" & strLogFile, 0, True
'WriteTextFiles VbCrLf&"строка61", strLogFile
WshShell.Run "%comspec% /u /c chcp 65001 & for /f ""eol=; tokens=1 skip=2"" %i in ('quser') do qprocess %i >>" & strLogFile, 0, True
WshShell.Run "%comspec% /u /c chcp 65001 & for /f ""eol=; tokens=2 skip=1"" %i in ('quser') do if /i not ""%i""==""console"" logoff %i /v >>" & strLogFile, 0, True
WriteTextFiles vbcrlf & Now & " Проверка наличия незавершившихся терминальных сессий"&vbcrlf, strLogFile
WshShell.Run "%comspec% /u /c chcp 65001 & quser >>" & strLogFile, 0, True
'WriteTextFiles VbCrLf, strLogFile
'==================================
' Архивация баз за прошедшие сутки
'==================================
WriteTextFiles vbcrlf&Now & " Создание списка исключений для архиватора: " & strExcFile, strLogFile
WriteTextFiles "*.cdx", strExcFile
WriteTextFiles Now & " Cуточная архивация баз " & strDataPath & " ===> " & strPathArchiveLocal & strDirDaily, strLogFile 'strSubject более нигде не используется ?
If objFSO.FolderExists(strPathArchiveLocal & strDirDaily) = False Then objFSO.CreateFolder(strPathArchiveLocal & strDirDaily)
' Вычисление размера архивируемой директории
Set objFolder = objFSO.GetFolder(strDataPath)
WriteTextFiles vbTab&vbTab&" "& " Размер архивируемой директории: " & strDataPath & " - " & Round(objFolder.Size / 1048576,2) & " Mb", strLogFile
' Запуск программы-архиватора
if PassForArc <> "" then
WshShell.Run "%comspec% /a /c echo &" & chr(34) & strPathToArchiver & "Rar.exe" & chr(34) & " a -ep1 -r -se -rr10p -m5 -dh -hp"&PassForArc&" -x@" & strExcFile & " -ilog:" & strArcErrLogFile & " " & strPathArchiveLocal & strDirDaily & strDataDailyFileName & " " & strDataPath & "*", 0, True
else
WshShell.Run "%comspec% /a /c echo &" & chr(34) & strPathToArchiver & "Rar.exe" & chr(34) & " a -ep1 -r -se -rr10p -m5 -dh -x@" & strExcFile & " -ilog:" & strArcErrLogFile & " " & strPathArchiveLocal & strDirDaily & strDataDailyFileName & " " & strDataPath & "*", 0, True
end if
' Вычисление размера созданного архива
If objFSO.FileExists(strPathArchiveLocal & strDirDaily & strDataDailyFileName & ".rar") = true Then
Set objTestFile = objFSO.GetFile(strPathArchiveLocal & strDirDaily & strDataDailyFileName & ".rar")
WriteTextFiles vbTab&vbTab&" "& " Размер созданного суточного архива: " & objTestFile & " - " & Round(objTestFile.Size / 1048576,2) & " Mb", strLogFile
Else
WriteTextFiles vbTab&vbTab&" "& " ОШИБКА: Файл: " & strPathArchiveLocal & strDirDaily & strDataDailyFileName & ".rar не создан", strLogFile
If objFSO.FileExists(strExcFile) Then objFSO.DeleteFile(strExcFile)
objFSO.MoveFile strLogFile, strLogFile & ".err"
WScript.Quit
End If
If objFSO.FileExists(strExcFile) Then objFSO.DeleteFile(strExcFile)
'=======================================
' Копирование архива за прошедшие сутки
'=======================================
' На сетевой ресурс
'strReturn = CopyNewArcFiles (strPathArchiveLocal & strDirDaily, strPathArchiveRemote & strDirDaily)
'strReturn = sendFile2webdav (strPathArchiveLocal & strDirDaily & strDataDailyFileName & ".rar", strPathArchiveRemote & strDirDaily)
strReturn = sendFolder2webdav (strPathArchiveLocal & strDirDaily , strPathArchiveRemote & strDirDaily)
'WriteTextFiles strReturn, strLogFile
' Удаление неактуальных суточных архивов
WriteTextFiles Now & " Удаление архивов старше " & nDays & " суток", strLogFile
' На локальном диске
strReturn = DeleteOldFiles (nDays, strPathArchiveLocal & strDirDaily, "d")
WriteTextFiles strReturn, strLogFile
' На сетевом ресурсе
'strReturn = DeleteOldFiles (nDays, strPathArchiveRemote & strDirDaily, "d")
strReturn = webDavDeleteOldFiles(nDays, strPathArchiveRemote & strDirDaily, "d")
WriteTextFiles strReturn, strLogFile
'========================================
' Копирование архива за прошедшую неделю
'========================================
If WeekDay(strDateStart, 2) = 1 Then
' На локальный диск
strReturn = CopyNewArcFiles (strPathArchiveLocal & strDirDaily, strPathArchiveLocal & strDirWeekly)
WriteTextFiles strReturn, strLogFile
' На сетевой ресурс
'strReturn = CopyNewArcFiles (strPathArchiveRemote & strDirDaily, strPathArchiveRemote & strDirWeekly)
strReturn = WebDavDoCopyMove (strPathArchiveRemote & strDirDaily, strPathArchiveRemote & strDirWeekly, true)
WriteTextFiles strReturn, strLogFile
' Удаление неактуальных недельных архивов
WriteTextFiles Now & " Удаление архивов старше " & nWeeks & " недель", strLogFile
' На локальном диске
strReturn = DeleteOldFiles (nWeeks, strPathArchiveLocal & strDirWeekly, "ww")
WriteTextFiles strReturn, strLogFile
' На сетевом ресурсе
'strReturn = DeleteOldFiles (nWeeks, strPathArchiveRemote & strDirWeekly, "ww")
strReturn = webDavDeleteOldFiles (nWeeks, strPathArchiveRemote & strDirWeekly, "ww")
WriteTextFiles strReturn, strLogFile
End If
'=======================================
' Копирование архива за прошедший месяц
'=======================================
If Day(strDateStart) = 1 Or _
((Day(strDateStart) = 2 Or Day(strDateStart) = 3) And WeekDay(strDateStart, 2) = 1) Then
' На локальный диск
strReturn = CopyNewArcFiles (strPathArchiveLocal & strDirDaily, strPathArchiveLocal & strDirMonthly)
WriteTextFiles strReturn, strLogFile
' На сетевой ресурс
'strReturn = CopyNewArcFiles (strPathArchiveRemote & strDirDaily, strPathArchiveRemote & strDirMonthly)
strReturn = WebDavDoCopyMove (strPathArchiveRemote & strDirDaily, strPathArchiveRemote & strDirMonthly, true)
WriteTextFiles strReturn, strLogFile
' Удаление неактуальных месячных архивов
WriteTextFiles Now & " Удаление архивов старше " & nMonthes & " месяцев", strLogFile
' На локальном диске
strReturn = DeleteOldFiles (nMonthes, strPathArchiveLocal & strDirMonthly, "m")
WriteTextFiles strReturn, strLogFile
' На сетевом ресурсе
strReturn = webDavDeleteOldFiles (nMonthes, strPathArchiveRemote & strDirMonthly, "m")
WriteTextFiles strReturn, strLogFile
End If
'==============================================
' Функция копирования файлов созданных архивов
'==============================================
Function CopyNewArcFiles (strPathSrc, strPathDst)
strCopyLog = Now & " копирование созданного суточного архива" &vbcrlf
If objFSO.FolderExists(strPathDst) = False Then objFSO.CreateFolder(strPathDst)
objFSO.CopyFile strPathSrc & strDataDailyFileName & ".rar", strPathDst, True
If objFSO.FileExists(strPathDst & strDataDailyFileName & ".rar") = true Then
Set objTestFile = objFSO.GetFile(strPathDst & strDataDailyFileName & ".rar")
strCopyLog = strCopyLog & Now & " Файл: " & strDataDailyFileName & ".rar" & " скопирован в " & strPathDst
Else
strCopyLog = strCopyLog & Now & " ОШИБКА: Файл: " & strDataDailyFileName & ".rar" & " не скопирован в " & strPathDst
End If
CopyNewArcFiles = strCopyLog
End Function
'==============================================
' Функция удаления файлов неактуальных архивов
'==============================================
Function DeleteOldFiles (strPeriod, strPath, intrvl)
Set objFolder = objFSO.GetFolder(strPath)
Set objFiles = objFolder.Files
For Each File In objFiles
Result = Abs(DateDiff(intrvl, Now, File.DateCreated))
If Result > strPeriod-1 Then
strDeleteLog = strDeleteLog + vbTab & "Удален файл: " & File.Path & " от: " & File.DateCreated & VbCrLf
File.Delete
End If
Next
DeleteOldFiles = strDeleteLog
End Function
WriteTextFiles Now & " Архивация окончена. Время выполнения архивации: " & CDate(Time - strTimeStart), strLogFile
WriteTextFiles Now & " terminating...", strLogFile
'=======================
' Копирование лог-файла
'=======================
' Ежедневный
If objFSO.FileExists(strLogFile) Then
objFSO.CopyFile strLogFile, strPathArchiveLocal & strDirDaily, True
'objFSO.CopyFile strLogFile, strPathArchiveRemote & strDirDaily, True
sendFile2webdav strLogFile, strPathArchiveRemote & strDirDaily
' Еженедельный
If WeekDay(strDateStart, 2) = 1 Then
If objFSO.FileExists(strLogFile) Then
objFSO.CopyFile strLogFile, strPathArchiveLocal & strDirWeekly, True
'objFSO.CopyFile strLogFile, strPathArchiveRemote & strDirWeekly, True
sendFile2webdav strLogFile, strPathArchiveRemote & strDirWeekly
End If
End If
' Ежемесячный
If Day(strDateStart) = 1 Or _
((Day(strDateStart) = 2 Or Day(strDateStart) = 3) And WeekDay(strDateStart, 2) = 1) Then
If objFSO.FileExists(strLogFile) Then
objFSO.CopyFile strLogFile, strPathArchiveLocal & strDirMonthly, True
'objFSO.CopyFile strLogFile, strPathArchiveRemote & strDirMonthly, True
sendFile2webdav strLogFile, strPathArchiveRemote & strDirMonthly
End If
End If
' Удаление временного лога
objFSO.DeleteFile(strLogFile)
End If
Set WshShell = Nothing
Set objFSO = Nothing
WScript.Quit
Sub WriteTextFiles (strText, strPath)
'===================================
' Процедура записи текстового файла
'===================================
Set objFile = objFSO.OpenTextFile(strPath, 8, True)
objFile.WriteLine(strText)
objFile.Close
End Sub
Sub WriteTextFilesStandalone (strText, strPath)
Set objFile = CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 8, True)
objFile.WriteLine(strText)
objFile.Close
Set objFile = Nothing
End Sub
function isFolderExist(strDest)
'проверяет существует ли папка
'возвращает true если папка существует и false если нет
'msgbox "isFolderExist = "&isFolderExist(baseURI & "ssa\")
Dim XMLreq
Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
Dim sSourceURL
sSourceURL = backslash2slash(strDest)
XMLreq.open "PROPFIND", sSourceURL, False, UploadUser, UploadPass
XMLreq.setRequestHeader "Content-Type", "text/xml"
XMLreq.setRequestHeader "Depth", 1 'цифру указывать в кавычказ или нет? - пофиг
'XMLreq.setRequestHeader "Translate", "f"
'XMLreq.setRequestHeader "Brief", "t" 'The default setting is "f".
XMLreq.send "<!--?xml version='1.0'?--><d:propfind xmlns:d="DAV:"><d:prop><d:resourcetype></d:resourcetype></d:prop></d:propfind>"
'MsgBox XMLreq.status ' 207 есть 404 нет
'WriteTextFiles XMLreq.responsetext, "XMLreq.responsetext.txt"
'msgbox XMLreq.responseXML.namespaces()
'XMLreq.responseXML.setProperty "SelectionNamespaces", "xmlns:ms='urn:schemas-microsoft-com:xslt'"
'msgbox "SelectionNamespaces " & XMLreq.responseXML.getProperty("SelectionNamespaces")
'msgbox "getProperty1 " & XMLreq.responseXML.getProperty[0]
'msgbox XMLreq.responseXML.DocumentElement.GetPrefixOfNamespace("DAV:")
'Dim Node : Set Node = XMLreq.responseXML '.DocumentElement.selectSingleNode("multistatus")
'set Node = XMLreq.responseXML ' selectSingleNode("response")
'Node.setProperty "SelectionLanguage", "XPath"
'msgbox Node.getProperty("SelectionLanguage")
'ns = "xmlns:D='DAV:' "
'Node.SetProperty "SelectionNamespaces", ns
'msgbox Node.getProperty("SelectionNamespaces")
'MsgBox Node.selectSingleNode("href")
'MsgBox Node.selectNodes("multistatus", nsmgr) '.nodeName &" "& Node.text
'XMLreq.responseXML.selectSingleNode("status") ' &" "& Node.text
strStatus = XMLreq.status
if strStatus = "207" then
isFolderExist = true
elseif strStatus = "404" then
isFolderExist = false
else isFolderExist = "isFolderExist function says: wrong status from server. XMLreq.status = "&XMLreq.status &" "& XMLreq.statusText
end if
'MsgBox XMLreq.responseXML.getElementsByTagName("D:status").nextNode.Text 'HTTP/1.1 200 OK 'ничего не возвращает если ответ 404
'Dim objNodeList
'Dim msg
'Set objNodeList = XMLreq.responseXML.getElementsByTagName("D:status")
'For i = 0 TO (objNodeList.length -1)
' Set objNode = objNodeList.nextNode
' msg = msg & "x " & objNode.NamespaceURI & " " & objNode.NodeName &" "& objNode.Text & Vbcrlf
'Next
'MsgBox msg
Set XMLreq = Nothing
End function
function isFileExist(strDest)
'проверяет существует ли файл
'возвращает true если файл существует и false если нет
'слеш вконце даёт ошибку
'msgbox isFileExist(baseURI&"WriteTextFilesAppendToLine.vbs")
Dim XMLreq
Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
Dim sSourceURL
sSourceURL = backslash2slash(strDest)
If (Right(sSourceURL,1)) = "/" Then
sSourceURL = Left(sSourceURL, Len(sSourceURL)-1)
Else
sSourceURL = sSourceURL
End If
XMLreq.open "PROPFIND", sSourceURL, False, UploadUser, UploadPass
XMLreq.setRequestHeader "Content-Type", "text/xml"
XMLreq.setRequestHeader "Depth", 1 'цифру указывать в кавычказ или нет? - пофиг
'XMLreq.setRequestHeader "Translate", "f"
'XMLreq.setRequestHeader "Brief", "t" 'The default setting is "f".
XMLreq.send "<!--?xml version='1.0'?--><d:propfind xmlns:d="DAV:"><d:prop><d:resourcetype></d:resourcetype></d:prop></d:propfind>"
strStatus = XMLreq.status
if strStatus = "207" then
isFileExist = true
elseif strStatus = "404" then
isFileExist = false
else isFileExist = "isFileExist function says: wrong status from server. XMLreq.status = "&XMLreq.status &" "& XMLreq.statusText
end if
Set XMLreq = Nothing
End function
function webDavMakeFolder(strUrlFolderToCreate)
'создаёт папку если она не существует
'возвращает true если папка создана и false если нет
'msgbox "webDavMakeFolder = "&webDavMakeFolder(baseURI & "ssasdfgsdfgsdfg")
'может только один уровень создать т.е. если есть папка https://webdav.example.com/user/ то webDavMakeFolder не сможет сделать .../user/folder1/folder2 возвращает статус 409 Conflict
'msgbox webDavMakeFolder(baseURI & "zzz")
if isFolderExist(strUrlFolderToCreate) = false then
Dim XMLreq
Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
Dim sSourceURL
sSourceURL = backslash2slash(strUrlFolderToCreate)
strCopyLog = Now & " создаю папку "& sSourceURL & "..."
XMLreq.open "MKCOL", sSourceURL, False, UploadUser, UploadPass
XMLreq.setRequestHeader "Content-Type", "text/xml"
'XMLreq.setRequestHeader "Content-Length", "XXX"
XMLreq.send
'MsgBox XMLreq.Status
If XMLreq.Status = "201" Or XMLreq.Status = "207" Then
'MsgBox "The folder has been created. Status is " & XMLreq.statusText, vbCritical, "Folder Created!!"
webDavMakeFolder = true
strCopyLog = strCopyLog & "well done."
Elseif XMLreq.Status = "404" then
'Note: Error 405 can mean permissions problem on item already exists.
'MsgBox "The folder has not been created. Status is " & XMLreq.statusText, vbCritical, " Folder not Created!!"
webDavMakeFolder = false
strCopyLog = strCopyLog & "АШЫПКО ДЭТЕКТЕД! Папка не создана."
else
webDavMakeFolder = "webDavMakeFolder function says: wrong status from server. XMLreq.status = "&XMLreq.status &" "& XMLreq.statusText
strCopyLog = strCopyLog & "АШЫПКО ДЭТЕКТЕД! Папка не создана. webDavMakeFolder function says: wrong status from server. XMLreq.status = "&XMLreq.status &" "& XMLreq.statusText
End If
Set XMLreq = Nothing
else
webDavMakeFolder = "folder already created"
end if
WriteTextFiles strCopyLog, strLogFile
End function
function webDavDeleteFolder(strUrlFolderToDelete)
'webDavDeleteFolder(baseURI & "ssb") 'для папки слеш вконце обязателен
'может удалить только последний уровень т.е. если есть папка https://webdav.example.com/user/folder1/folder2/ то webDavDeleteFolder если путь: .../user/folder1/folder2 возвращает статус 204 и удаляет только последнюю папку (folder2), если папки нет то возваращает 404.
'если есть папка .../folder1/folder2/ а команда на удаление .../folder1/ то удалит рекурсивно вместе с файлами
'если есть папка .../folder1/ а команда на удаление .../folder1/folder2/ то ни чего не удалит
'как оказалось файл нельзя удалять со слешем вконце. но это было поправлено -> см webDavDeleteFile
'msgbox webDavDeleteFolder(baseURI & "/folder1/folder2/")
'msgbox strUrlFolderToDelete
Dim XMLreq : Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
Dim sSourceURL : sSourceURL = backslash2slash(strUrlFolderToDelete)
strCopyLog = Now & " удаляю папку "& sSourceURL & "..."
'msgbox sSourceURL
XMLreq.open "DELETE", sSourceURL, False, UploadUser, UploadPass
XMLreq.setRequestHeader "Content-Type", "text/xml"
'XMLreq.setRequestHeader "Content-Length", "XXX"
XMLreq.send
'webDavDeleteFolder = XMLreq.Status 'при удалении папки код 204, и 404 если не найдено
If XMLreq.Status = "204" Then
'MsgBox "The folder has been created. Status is " & XMLreq.statusText, vbCritical, "Folder Created!!"
webDavDeleteFolder = true
strCopyLog = strCopyLog & " удалено."
Elseif XMLreq.Status = "404" Then
webDavDeleteFolder = false
strCopyLog = strCopyLog & " НЕ удалено."
'Note: Error 405 can mean permissions problem on item already exists.
'MsgBox "The folder has not been created. Status is " & XMLreq.statusText, vbCritical, " Folder not Created!!"
Else
webDavDeleteFolder = "webDavDeleteFolder say's: something goes wrong - XMLreq.Status = "&XMLreq.Status &" "& XMLreq.StatusText
strCopyLog = strCopyLog & " НЕ удалено! АШЫПКО ДЭТЕКТЕД! webDavDeleteFolder say's: something goes wrong - XMLreq.Status = "&XMLreq.Status &" "& XMLreq.StatusText
End If
Set XMLreq = nothing
WriteTextFiles strCopyLog, strLogFile
End function
function webDavDeleteFile(strUrlFileToDelete)
'удаляет файл возвращает true или false
'msgbox strUrlFileToDelete
Dim XMLreq : Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
Dim sSourceURL : SourceURL = backslash2slash(strUrlFileToDelete)
If (Right(sSourceURL,1)) = "/" Then
sSourceURL = Left(sSourceURL, Len(sSourceURL)-1)
Else
sSourceURL = sSourceURL
End If
strCopyLog = Now & " удаляю файл "& sSourceURL & "..."
'msgbox sSourceURL
XMLreq.open "DELETE", sSourceURL, False, UploadUser, UploadPass
XMLreq.setRequestHeader "Content-Type", "text/xml"
'XMLreq.setRequestHeader "Content-Length", "XXX"
XMLreq.send
'webDavDeleteFile = XMLreq.Status 'при удалении папки код 204, и 404 если не найдено
If XMLreq.Status = "204" Then
'MsgBox "The folder has been created. Status is " & XMLreq.statusText, vbCritical, "Folder Created!!"
webDavDeleteFile = true
strCopyLog = strCopyLog & " файл был удален."
Elseif XMLreq.Status = "404" Then
webDavDeleteFile = false
strCopyLog = strCopyLog & " файл НЕ был удален."
'Note: Error 405 can mean permissions problem on item already exists.
'MsgBox "The folder has not been created. Status is " & XMLreq.statusText, vbCritical, " Folder not Created!!"
Else
webDavDeleteFile = "webDavDeleteFile say's: something goes wrong - XMLreq.Status = "&XMLreq.Status &" "& XMLreq.StatusText
strCopyLog = strCopyLog & " файл НЕ был удален. АШЫПКО ДЭТЕКТЕД! webDavDeleteFile say's: something goes wrong - XMLreq.Status = "&XMLreq.Status &" "& XMLreq.StatusText
End If
Set XMLreq = nothing
WriteTextFiles strCopyLog, strLogFile
End function
function sendFile2webdav (strUploadFilePath, strUrlUploadDestWithoutFilename)
'baseURI without filename
'msgbox sendFile2webdav ("C:\shkur\WriteTextFilesAppendToLine.txt", baseURI)
UploadType = "binary"
strUrlUploadDestWithoutFilename = backslash2slash(strUrlUploadDestWithoutFilename) 'чтобы точно был слеш вконце
strCopyLog = Now & " копирую файл от сюда "& strUploadFilePath& " сюда " &strUrlUploadDestWithoutFilename &"..."&vbcrlf
if isFolderExist(strUrlUploadDestWithoutFilename) = false then webDavMakeFolder(strUrlUploadDestWithoutFilename)
'msgbox "strUploadFilePath = "&strUploadFilePath & vbcrlf& "strUrlUploadDestWithoutFilename = "&strUrlUploadDestWithoutFilename 'Vbcrlf
sfileName= mid(strUploadFilePath, InstrRev(strUploadFilePath,"\")+1,len(strUploadFilePath))
'strURL = strUrlUploadDestWithoutFilename & "/" & strUploadFilePath
'strURL = strUrlUploadDestWithoutFilename & "/" & sfileName
dim strURL : strURL = strUrlUploadDestWithoutFilename & sfileName
if isFileExist(strURL) = false then
sData = getFileBytes(strUploadFilePath, UploadType)
dim xmlhttp : set xmlhttp=createobject("MSXML2.XMLHTTP.3.0")
'msgbox "Upload-URL: " & strURL
xmlhttp.Open "PUT", strURL, false, UploadUser, UploadPass
xmlhttp.Send sData
'Wscript.Echo "Upload-Status: " & xmlhttp.statusText & " " & xmlhttp.status
'sendFile2webdav
If (xmlhttp.status >= 200 And xmlhttp.status < 300) Then
'wscript.echo "PUT: Success! " & "Results = " & xmlhttp.status & ": " & xmlhttp.statusText
sendFile2webdav = True
strCopyLog = strCopyLog & Now & " Файл: " & sfileName & " скопирован в " & strUrlUploadDestWithoutFilename
ElseIf xmlhttp.status = 401 Then
'wscript.echo "PUT: You don't have permission to do the job! Please check your permissions on this item."
sendFile2webdav = False
strCopyLog = strCopyLog & Now & " ОШИБКА: Файл: " & sfileName & " НЕ скопирован в " & strUrlUploadDestWithoutFilename
Else
'wscript.echo "PUT: Request Failed. Results = " & xmlhttp.status & ": " & xmlhttp.statusText
sendFile2webdav = False
strCopyLog = strCopyLog & Now & " ОШИБКА: Файл: " & sfileName & " НЕ скопирован в " & strUrlUploadDestWithoutFilename & " sendFile2webdav say's: something goes wrong - XMLreq.Status = "&xmlhttp.status &" "& xmlhttp.statusText
End If
set xmlhttp=Nothing
else
sendFile2webdav = False
strCopyLog = strCopyLog & Now & " file "& strURL &" already exists!"
End If
WriteTextFiles strCopyLog, strLogFile
End function
function sendFolder2webdav(strUploadFolderPath, strUrlUploadDestWithoutFilename)
'отправляет папку на webdav
strCopyLog = Now & " отправляю папку "& strUploadFolderPath &" на webdav "& strUrlUploadDestWithoutFilename &"..."
listLocalFiles = listFilesLocalFolder(strUploadFolderPath)
x=1
for each flnm in listLocalFiles
sendFile2webdav strUploadFolderPath & flnm, strUrlUploadDestWithoutFilename
x=x+1
next
strCopyLog = strCopyLog & "отправлено "&x&"файлов."
WriteTextFiles strCopyLog, strLogFile
End function
Function WebDavDoCopyMove(sSourceURL, sDestinationURL, bCopy)
''---------------------------------------------------------------------------------
' WebDavDoCopyMove - Used to move an item from one folder to another in the same store.
' sSourceURL - item being moved/copied
' sDestinationURL - the URL it is going to
' bCopy - TRUE if copying or FALSE if moving
'---------------------------------------------------------------------------------
strCopyLog = Now & " копирую на webdav'е от сюда "& sSourceURL &" сюда "& sDestinationURL & "..." & vbcrlf
Set oXMLHttp = CreateObject("microsoft.xmlhttp") ' = New MSXML2.XMLHTTP30
Dim sVerb
If bCopy = True Then sVerb = "COPY" Else sVerb = "MOVE" End If
If sUser <> "" Then
oXMLHttp.Open sVerb, sSourceURL, False, UploadUser, UploadPass
Else
oXMLHttp.Open sVerb, sSourceURL, False ', sUser, sPassword
End If
oXMLHttp.setRequestHeader "Destination", sDestinationURL
'oXMLHttp.setRequestHeader "Overwrite", "T"
' Send the stream across
oXMLHttp.Send
If (oXMLHttp.Status >= 200 And oXMLHttp.Status < 300) Then
'wscript.echo "Success! " & "Results = " & oXMLHttp.Status & ": " & oXMLHttp.statusText
WebDavDoCopyMove = true
strCopyLog = strCopyLog & Now & " Скопировал от сюда "& sSourceURL &" сюда "& sDestinationURL
ElseIf oXMLHttp.Status = 401 Then
'wscript.echo "You don't have permission to do the job! Please check your permissions on this item."
WebDavDoCopyMove = false
strCopyLog = strCopyLog & Now & " Не получилось скопипастить от сюда "& sSourceURL &" сюда "& sDestinationURL &" т.к. не хватает прав."
Else
'wscript.echo "Request Failed. Results = " & oXMLHttp.Status & ": " & oXMLHttp.statusText
WebDavDoCopyMove = false
strCopyLog = strCopyLog & Now & " АШЫПКО ДЭТЕКТЕД! WebDavDoCopyMove говорит:"& oXMLHttp.Status &" "& oXMLHttp.statusText &" ну что, красноглазый :)"
End If
WriteTextFiles strCopyLog, strLogFile
Set oXMLHttp = Nothing
End Function
function getFileBytes(flnm, sType)
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
if sType="binary" then
objStream.Type = 1 ' adTypeBinary
else
objStream.Type = 2 ' adTypeText
objStream.Charset ="ascii"
end if
objStream.Open
objStream.LoadFromFile flnm
if sType="binary" then
getFileBytes=objStream.Read 'read binary'
else
getFileBytes= objStream.ReadText 'read ascii'
end if
objStream.Close
Set objStream = Nothing
end function
Function webDavDeleteOldFiles (strPeriod, strPath, intrvl)
'webDavDeleteOldFiles 1, strURL, "d"
'strPath - папка без имени файла со слешем вконце
'return log
strPath = backslash2slash(strPath)
strDeleteLog = Now & " удаляю файлы из "& strPath & "..." &vbcrlf
arrListFiles = webDavListOnlyFiles(strPath)
For Each File In arrListFiles
'msgbox File(1)
Result = Abs(DateDiff(intrvl, Now, CDate(Replace(Replace(File(1),"T"," "),"Z"," "))))
'msgbox Result
If Result > strPeriod-1 Then
'msgbox "kukara4a"
wddofRet = webDavDeleteFile(strPath&File(0))
if wddofRet = true then
strDeleteLog = now & " Удален файл: " & File(0) & " от: " & File(1)
elseif wddofRet = false then
strDeleteLog = now & " Файл НЕ удален: " & File(0) & " от: " & File(1)
else
strDeleteLog = now &" "& wddofRet
End If
End If
Next
webDavDeleteOldFiles = strDeleteLog
End Function
'iterate2ndArray(webDavListOnlyFiles(strURL))
'dim ret()
'ret = webDavListOnlyFiles(strURL)
'msgbox ret(1)(0)
'iterate2ndArray(webDavListOnlyFiles(strURL)) 'return 2D-array 1st array is index, second file name, Date
function webDavListOnlyFiles(strURL) 'with trailing slash 'return obj or array?
Set XMLreq = createobject("MSXML2.XMLHTTP.3.0")
sSourceURL = backslash2slash(strURL)
XMLreq.open "PROPFIND", sSourceURL, False, "UploadUser", "UploadPass"
XMLreq.setRequestHeader "Content-Type", "text/xml"
XMLreq.setRequestHeader "Depth", 1 'цифру указывать в кавычказ или нет? - пофиг
'XMLreq.setRequestHeader "Translate", "f"
'XMLreq.setRequestHeader "Brief", "t" 'The default setting is "f".
'XMLreq.send "<!--?xml version='1.0'?--><d:propfind xmlns:d="DAV:"><d:allprop></d:allprop></d:propfind>"
XMLreq.send "<!--?xml version='1.0'?--><d:propfind xmlns:d="DAV:"><d:prop><d:resourcetype><d:collection></d:collection></d:resourcetype><d:creationdate></d:creationdate></d:prop></d:propfind>"
'WriteTextFilesStandalone XMLreq.responseText, "C:\shkur\tmpCopy\xml.xml"
'MsgBox XMLreq.responseXML.getElementsByTagName("D:status").nextNode.Text 'HTTP/1.1 200 OK 'ничего не возвращает если ответ 404
Set objNodeList1 = XMLreq.responseXML.getElementsByTagName("D:href")
Set objNodeList2 = XMLreq.responseXML.getElementsByTagName("lp1:creationdate")
dim arr1st()
'dim arr2nd() ' несоответствие типа
''Set arr1st = CreateObject("Scripting.Dictionary")
x=0
For i = 0 TO (objNodeList1.length -1)
''Set arr2nd = CreateObject("Scripting.Dictionary")
Set objNode1 = objNodeList1.nextNode
set objNode2 = objNodeList2.nextNode
If (Right(objNode1.text,1)) <> "/" Then 'trailing slash = folder
flnm = (mid(objNode1.text,(InStrRev(objNode1.text,"/"))+1))
creationdate = CDate(Replace(Replace(objNode2.text,"T"," "),"Z"," "))
'msg = msg & x & ". " & flnm & " "& objNode2.text &" "& Vbcrlf
''arr2nd.Add "flnm", flnm
''arr2nd.Add "creationdate", objNode2.text
arr2nd = array(flnm, creationdate)
ReDim Preserve arr1st(x)
arr1st(x)=arr2nd
x=x+1
''arr1st.Add x, arr2nd
End If
Set arr2nd = Nothing
Next
'MsgBox msg
Set XMLreq = Nothing
webDavListOnlyFiles = arr1st
'iterate2ndArray(arr1st)
'msgbox isarray(arr1st)
'msgbox isarray(arr1st(0))
'Set arr1st = Nothing 'несоответствие типа...
End Function
function listFilesLocalFolder(strPathSrc)
'Set fso = CreateObject("Scripting.FileSystemObject") 'заменить на objFSO
Set files = objFSO.GetFolder(strPathSrc).Files
dim array1st()
x=0
For each folderIdx In files
ReDim Preserve arr1st(x)
arr1st(x) = folderIdx.Name
x=x+1
'msg = msg & folderIdx.Name & vbcrlf
Next
'msgbox msg
listFilesLocalFolder = arr1st
'Set fso = nothing
End function
function backslash2slash(strUrl)
'поменять бекслеши на слеши и добавить слеш вконце
'msgbox backslash2slash("https://www.w3school///s.com/\\\\\vbscript/func_instr.asp")
leftSide = (Left(strUrl,(InStr(strUrl,"://"))+2))
rightSide = (Right(strUrl,(Len(strUrl)-InStr(strUrl,"://")-2)))
rightSide = Replace(Replace(Replace(Replace(rightSide,"\","/"),"///","/"),"//","/"),"//","/")
concat = leftSide&rightSide
If (Right(concat,1)) <> "/" Then
backslash2slash = concat & "/"
Else
backslash2slash = concat
End If
End function
'iterate2ndArray(test())
function test()
b=Array("b1","b2")
c=Array("c1","c2")
d=Array("d1","d2")
f=Array("f1","f2")
'a=Array(b,c,d,f)
dim a(3)
a(0)=b
a(1)=c
a(2)=d
a(3)=f
msgbox isArray(a(0))
test = a
end function
function iterate2ndArray(a)
if isArray(a) = false then
msgbox "это не массив"
else
msg = "begin:"&vbcrlf
for each x in a
'msg = msg & "1st array:"& x
for each xx in x
msg = msg & " " & xx
'msgbox xx
next
msg = msg & vbcrlf
next
msgbox msg
end if
End Function
function iterate1stArray(a)
if isArray(a) = false then
msgbox "это не массив"
else
msg = "begin:"&vbcrlf
for each x in a
msg = msg & " " & x
msg = msg & vbcrlf
next
msgbox msg
end if
End Function
profitness
не многовато, делал на bat в 4 раза короче
не многовато, делал на bat в 4 раза короче
Скрипт резервного копирования для платформы 8.2 (создайте файл с расширением vbs)
Например - start.vbs
Например - start.vbs
[more] ' БД, хранимой в серверном варианте
' В случае использования файлового варианта хранения данных следует
' закомментировать фрагмент с пометкой СЕРВЕР и
' раскомментировать с пометкой ФАЙЛ (или удалить).
' Также грамотно следует выставить параметры.
Dim WshShell, Programs1c
' Каталог хранения резервных копий
DumpPath = "c:\Base\buh3"
' Название резервной копии, к которой будут дабавляться дата и время создания
FileName = "Теплосервис_БП_v3" ' Название бэкапа базы
' Используются для серверного варианта хранения
ServerName = "serv1cnew" ' Название сервера 1С Предприятия
InfoBaseName = "test1" ' Имя архивируемой базы
' Кластер на сервере 1С
ClasterPortNumber = 1541
' Для серверного варианта: Chr(34) + ServerName + "\" + InfoBaseName + Chr(34)
' Для файлового варианта: путь к базе, например, f:\1c_enterprise
DBPath = Chr(34) + ServerName + ":" + CStr(ClasterPortNumber) + "\" + InfoBaseName + Chr(34)
' Для серверного варианта: "/S", для файлового "/F"
BaseParam = "/S"
' Эти данные лучше в скрипте не светить, а использовать Windows аунтификацию
' Имя и Пароль пользователя назначенного для архивирования
InfoBasesAdminName = "robot"
InfoBasesAdminPass = "robot"
' Имя и Пароль Администратора кластера
' Не используется --------------------
ClasterAdminName = "Admin"
ClasterAdminPass = "admin"
ClasterAdminName = ""
ClasterAdminPass = ""
LockPermissionCode = "ПакетноеОбновлениеКонфигурацииИБ" ' Код блокировки базы
LockMessageText = vbCrLf + "БАЗА ЗАКРЫТА НА СОЗДАНИЕ РЕЗЕРВНОЙ КОПИИ" + vbCrLf + "Администратор - БАЗЫ"
LockTimeHours = 0.2 'Время блокирования БД в часах
' На самом деле данный параметр достаточно установить равным 1,
' ибо блокировка с БД всё равно снимается после архивирования
FindInfoBase = False 'Флаг, что ИБ найдена
Done = False 'Флаг выполнения архивирования
Set WshShell = CreateObject("WScript.Shell")
' Для корректного определения зарегистрированного приложения 1С
'PrgDirx86 = WshShell.RegRead("HKEY_CLASSES_ROOT\CLSID\{b3a7d9db-3cba-47f4-b80a-5dda79d8925a}\LocalServer32\")
PrgDirx86 = "C:\Program Files\1cv82\8.2.18.109\bin\1cv8.exe"
If InStr(PrgDirx86, " ") <> 0 Then
PrgDirx86 = Chr(34) + PrgDirx86 + Chr(34)
End If
strNow = Now()
FullPathName = DumpPath & "\" & _
Right("0" & Day(strNow), 2) & "_" & Right("0" & Month(strNow), 2) & "_" + Right(Year(strNow), 2) & "_" & _
Right("0" & Hour(strNow), 2) & "_" & Right("0" & Minute(strNow), 2) & "_" + Right(Second(strNow), 2) & "_" & _
FileName & ".dt"
If InStr(FullPathName, " ") <> 0 Then
FullPathName = Chr(34) + FullPathName + Chr(34)
End If
'------------------------------------------------------------------------------
' НАЧАЛО СЕРВЕР ---------------------------------------------------------------
'------------------------------------------------------------------------------
Set ComConnector = CreateObject("v82.COMConnector")
Set ServerAgent = ComConnector.ConnectAgent(ServerName)
' Получим массив кластеров сервера у агента сервера
Clasters = ServerAgent.GetClusters()
' Найдем необходимый нам кластер
For Each Claster In Clasters
'Wscript.Echo "Крутим в цикле кластеры: " & Claster.MainPort
If Claster.MainPort = ClasterPortNumber Then
'Wscript.Echo "Нашли искомый кластер!!! " & Claster.MainPort
ServerAgent.Authenticate Claster, ClasterAdminName, ClasterAdminPass
' Получаем список рабочих процессов
WorkingProcesses = ServerAgent.GetWorkingProcesses(Claster)
For Each WorkingProcess In WorkingProcesses
If WorkingProcess.Running = 1 Then
' Для каждого рабочего процесса создаем соединение с рабочим процессом
Set connecttoworkprocess = ComConnector.ConnectWorkingProcess("tcp://" + WorkingProcess.HostName + ":" + CStr(WorkingProcess.MainPort))
connecttoworkprocess.AuthenticateAdmin ClasterAdminName, ClasterAdminPass
connecttoworkprocess.AddAuthentication InfoBasesAdminName, InfoBasesAdminPass
If Not FindInfoBase Then
' Получаем список ИБ рабочего процесса
InfoBases = connecttoworkprocess.GetInfoBases()
For Each InfoBase In InfoBases
'Wscript.Echo UCase(InfoBase.Name)
' Ищем нужную базу
If UCase(InfoBase.Name) = UCase(InfoBaseName) Then
FindInfoBase = True
Exit For
End If
Next
If Not FindInfoBase Then ' Не нашли нужную базу
Wscript.Echo "Не нашли нужную базу " & UCase(InfoBaseName)
Exit For
End If
' Устанавливаем запрет на подключение новых соединений
InfoBase.ConnectDenied = True
InfoBase.ScheduledJobsDenied = True
InfoBase.DeniedFrom = CStr(Now())
InfoBase.DeniedTo = CStr(Now() + 1 / 24 * LockTimeHours)
InfoBase.DeniedMessage = LockMessageText
InfoBase.PermissionCode = LockPermissionCode
connecttoworkprocess.UpdateInfoBase (InfoBase)
'Wscript.Echo "Запретили доступ к ИБ"
End If
If FindInfoBase Then
'Wscript.Echo "Разрываем соединения с ИБ: " & UCase(InfoBaseName)
' Получаем массив соединений с ИБ
Connections = connecttoworkprocess.GetInfoBaseConnections(InfoBase)
For Each Connection In Connections
'Wscript.Echo Connection.AppId
' Разрываем Connections с ИБ
If Connection.AppId <> "SrvrConsole" Then
connecttoworkprocess.Disconnect (Connection)
End If
Next
' Запускаем архивацию
LineExe = PrgDirx86 + " CONFIG " + BaseParam + DBPath + _
" /N""" + InfoBasesAdminName + """ /P" + InfoBasesAdminPass + _
" /DumpIB" + FullPathName + " /UC" + LockPermissionCode + " /DisableStartupMessages"
Set Programs1c = WshShell.Exec( LineExe )
Do While Programs1c.Status = 0
WScript.Sleep 1000
Loop
Done = True
If Done Then
'Wscript.Echo "Архивация выполнена!"
Exit For
End If
End If
End If
If Done Then
Exit For
End If
Next
End If
If Done Then
Exit For
End If
Next
' Отключаем блокировку базы
FindInfoBase = False
WorkingProcesses = ServerAgent.GetWorkingProcesses(Claster)
For Each WorkingProcess In WorkingProcesses
If WorkingProcess.Running = 1 Then
' Для каждого рабочего процесса создаем соединение с рабочим процессом
Set connecttoworkprocess = ComConnector.ConnectWorkingProcess("tcp://" + WorkingProcess.HostName + ":" + CStr(WorkingProcess.MainPort))
connecttoworkprocess.AuthenticateAdmin ClasterAdminName, ClasterAdminPass
connecttoworkprocess.AddAuthentication InfoBasesAdminName, InfoBasesAdminPass
If Not FindInfoBase Then
' Получаем список ИБ рабочего процесса
InfoBases = connecttoworkprocess.GetInfoBases()
For Each InfoBase In InfoBases
' Ищем нужную базу
If UCase(InfoBase.Name) = UCase(InfoBaseName) Then
FindInfoBase = True
Exit For
End If
Next
If FindInfoBase Then
InfoBase.ConnectDenied = False
InfoBase.ScheduledJobsDenied = False
connecttoworkprocess.UpdateInfoBase (InfoBase)
'Wscript.Echo "Разрешили доступ к ИБ"
Exit For
End If
End If
End If
Next
ComConnector = Null
ServerAgent = Null
Clasters = Null
WorkingProcesses = Null
connecttoworkprocess = Null
InfoBases = Null
InfoBase = Null
Connections = Null
'------------------------------------------------------------------------------
' КОНЕЦ СЕРВЕР ----------------------------------------------------------------
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' НАЧАЛО ФАЙЛ -----------------------------------------------------------------
'------------------------------------------------------------------------------
'LineLOCKExe = PrgDirx86 + " ENTERPRISE " + BaseParam + DBPath + _
'" /N""" + InfoBasesAdminName + """ /P" + InfoBasesAdminPass + _
'" /DumpIB" + FullPathName + "/CЗавершитьРаботуПользователей /UC" + LockPermissionCode
'LineBAKExe = PrgDirx86 + " CONFIG " + BaseParam + DBPath + _
'" /N""" + InfoBasesAdminName + """ /P" + InfoBasesAdminPass + _
'" /DumpIB" + FullPathName + " /UC" + LockPermissionCode + " /DisableStartupMessages"
'LineUNLOCKExe = PrgDirx86 + " ENTERPRISE " + BaseParam + DBPath + _
'" /N""" + InfoBasesAdminName + """ /P" + InfoBasesAdminPass + _
'" /DumpIB" + FullPathName + "/CРазрешитьРаботуПользователей /UC" + LockPermissionCode
'Set Programs1c = WshShell.Exec(LineLOCKExe)
'Do While Programs1c.Status = 0
' WScript.Sleep 1000
'Loop
'Set Programs1c = WshShell.Exec(LineBAKExe)
'Do While Programs1c.Status = 0
' WScript.Sleep 1000
'Loop
'Set Programs1c = WshShell.Exec(LineUNLOCKExe)
'------------------------------------------------------------------------------
' КОНЕЦ ФАЙЛ ------------------------------------------------------------------
'------------------------------------------------------------------------------ [/more]
Добавлено:
Скрипт разблокировки базы после неудачного копирования 8.2 (создайте файл с расширением vbs)
Например unlock.vbs
Set oShell = WScript.CreateObject("WScript.Shell")
Set Programs1c = oShell.Exec("""C:\Program Files\1cv82\8.2.18.109\bin\1cv8.exe"" ENTERPRISE /S""serv1cnew:1541\test1"" /CРазрешитьРаботуПользователей /UCКодРазрешения")
' В случае использования файлового варианта хранения данных следует
' закомментировать фрагмент с пометкой СЕРВЕР и
' раскомментировать с пометкой ФАЙЛ (или удалить).
' Также грамотно следует выставить параметры.
Dim WshShell, Programs1c
' Каталог хранения резервных копий
DumpPath = "c:\Base\buh3"
' Название резервной копии, к которой будут дабавляться дата и время создания
FileName = "Теплосервис_БП_v3" ' Название бэкапа базы
' Используются для серверного варианта хранения
ServerName = "serv1cnew" ' Название сервера 1С Предприятия
InfoBaseName = "test1" ' Имя архивируемой базы
' Кластер на сервере 1С
ClasterPortNumber = 1541
' Для серверного варианта: Chr(34) + ServerName + "\" + InfoBaseName + Chr(34)
' Для файлового варианта: путь к базе, например, f:\1c_enterprise
DBPath = Chr(34) + ServerName + ":" + CStr(ClasterPortNumber) + "\" + InfoBaseName + Chr(34)
' Для серверного варианта: "/S", для файлового "/F"
BaseParam = "/S"
' Эти данные лучше в скрипте не светить, а использовать Windows аунтификацию
' Имя и Пароль пользователя назначенного для архивирования
InfoBasesAdminName = "robot"
InfoBasesAdminPass = "robot"
' Имя и Пароль Администратора кластера
' Не используется --------------------
ClasterAdminName = "Admin"
ClasterAdminPass = "admin"
ClasterAdminName = ""
ClasterAdminPass = ""
LockPermissionCode = "ПакетноеОбновлениеКонфигурацииИБ" ' Код блокировки базы
LockMessageText = vbCrLf + "БАЗА ЗАКРЫТА НА СОЗДАНИЕ РЕЗЕРВНОЙ КОПИИ" + vbCrLf + "Администратор - БАЗЫ"
LockTimeHours = 0.2 'Время блокирования БД в часах
' На самом деле данный параметр достаточно установить равным 1,
' ибо блокировка с БД всё равно снимается после архивирования
FindInfoBase = False 'Флаг, что ИБ найдена
Done = False 'Флаг выполнения архивирования
Set WshShell = CreateObject("WScript.Shell")
' Для корректного определения зарегистрированного приложения 1С
'PrgDirx86 = WshShell.RegRead("HKEY_CLASSES_ROOT\CLSID\{b3a7d9db-3cba-47f4-b80a-5dda79d8925a}\LocalServer32\")
PrgDirx86 = "C:\Program Files\1cv82\8.2.18.109\bin\1cv8.exe"
If InStr(PrgDirx86, " ") <> 0 Then
PrgDirx86 = Chr(34) + PrgDirx86 + Chr(34)
End If
strNow = Now()
FullPathName = DumpPath & "\" & _
Right("0" & Day(strNow), 2) & "_" & Right("0" & Month(strNow), 2) & "_" + Right(Year(strNow), 2) & "_" & _
Right("0" & Hour(strNow), 2) & "_" & Right("0" & Minute(strNow), 2) & "_" + Right(Second(strNow), 2) & "_" & _
FileName & ".dt"
If InStr(FullPathName, " ") <> 0 Then
FullPathName = Chr(34) + FullPathName + Chr(34)
End If
'------------------------------------------------------------------------------
' НАЧАЛО СЕРВЕР ---------------------------------------------------------------
'------------------------------------------------------------------------------
Set ComConnector = CreateObject("v82.COMConnector")
Set ServerAgent = ComConnector.ConnectAgent(ServerName)
' Получим массив кластеров сервера у агента сервера
Clasters = ServerAgent.GetClusters()
' Найдем необходимый нам кластер
For Each Claster In Clasters
'Wscript.Echo "Крутим в цикле кластеры: " & Claster.MainPort
If Claster.MainPort = ClasterPortNumber Then
'Wscript.Echo "Нашли искомый кластер!!! " & Claster.MainPort
ServerAgent.Authenticate Claster, ClasterAdminName, ClasterAdminPass
' Получаем список рабочих процессов
WorkingProcesses = ServerAgent.GetWorkingProcesses(Claster)
For Each WorkingProcess In WorkingProcesses
If WorkingProcess.Running = 1 Then
' Для каждого рабочего процесса создаем соединение с рабочим процессом
Set connecttoworkprocess = ComConnector.ConnectWorkingProcess("tcp://" + WorkingProcess.HostName + ":" + CStr(WorkingProcess.MainPort))
connecttoworkprocess.AuthenticateAdmin ClasterAdminName, ClasterAdminPass
connecttoworkprocess.AddAuthentication InfoBasesAdminName, InfoBasesAdminPass
If Not FindInfoBase Then
' Получаем список ИБ рабочего процесса
InfoBases = connecttoworkprocess.GetInfoBases()
For Each InfoBase In InfoBases
'Wscript.Echo UCase(InfoBase.Name)
' Ищем нужную базу
If UCase(InfoBase.Name) = UCase(InfoBaseName) Then
FindInfoBase = True
Exit For
End If
Next
If Not FindInfoBase Then ' Не нашли нужную базу
Wscript.Echo "Не нашли нужную базу " & UCase(InfoBaseName)
Exit For
End If
' Устанавливаем запрет на подключение новых соединений
InfoBase.ConnectDenied = True
InfoBase.ScheduledJobsDenied = True
InfoBase.DeniedFrom = CStr(Now())
InfoBase.DeniedTo = CStr(Now() + 1 / 24 * LockTimeHours)
InfoBase.DeniedMessage = LockMessageText
InfoBase.PermissionCode = LockPermissionCode
connecttoworkprocess.UpdateInfoBase (InfoBase)
'Wscript.Echo "Запретили доступ к ИБ"
End If
If FindInfoBase Then
'Wscript.Echo "Разрываем соединения с ИБ: " & UCase(InfoBaseName)
' Получаем массив соединений с ИБ
Connections = connecttoworkprocess.GetInfoBaseConnections(InfoBase)
For Each Connection In Connections
'Wscript.Echo Connection.AppId
' Разрываем Connections с ИБ
If Connection.AppId <> "SrvrConsole" Then
connecttoworkprocess.Disconnect (Connection)
End If
Next
' Запускаем архивацию
LineExe = PrgDirx86 + " CONFIG " + BaseParam + DBPath + _
" /N""" + InfoBasesAdminName + """ /P" + InfoBasesAdminPass + _
" /DumpIB" + FullPathName + " /UC" + LockPermissionCode + " /DisableStartupMessages"
Set Programs1c = WshShell.Exec( LineExe )
Do While Programs1c.Status = 0
WScript.Sleep 1000
Loop
Done = True
If Done Then
'Wscript.Echo "Архивация выполнена!"
Exit For
End If
End If
End If
If Done Then
Exit For
End If
Next
End If
If Done Then
Exit For
End If
Next
' Отключаем блокировку базы
FindInfoBase = False
WorkingProcesses = ServerAgent.GetWorkingProcesses(Claster)
For Each WorkingProcess In WorkingProcesses
If WorkingProcess.Running = 1 Then
' Для каждого рабочего процесса создаем соединение с рабочим процессом
Set connecttoworkprocess = ComConnector.ConnectWorkingProcess("tcp://" + WorkingProcess.HostName + ":" + CStr(WorkingProcess.MainPort))
connecttoworkprocess.AuthenticateAdmin ClasterAdminName, ClasterAdminPass
connecttoworkprocess.AddAuthentication InfoBasesAdminName, InfoBasesAdminPass
If Not FindInfoBase Then
' Получаем список ИБ рабочего процесса
InfoBases = connecttoworkprocess.GetInfoBases()
For Each InfoBase In InfoBases
' Ищем нужную базу
If UCase(InfoBase.Name) = UCase(InfoBaseName) Then
FindInfoBase = True
Exit For
End If
Next
If FindInfoBase Then
InfoBase.ConnectDenied = False
InfoBase.ScheduledJobsDenied = False
connecttoworkprocess.UpdateInfoBase (InfoBase)
'Wscript.Echo "Разрешили доступ к ИБ"
Exit For
End If
End If
End If
Next
ComConnector = Null
ServerAgent = Null
Clasters = Null
WorkingProcesses = Null
connecttoworkprocess = Null
InfoBases = Null
InfoBase = Null
Connections = Null
'------------------------------------------------------------------------------
' КОНЕЦ СЕРВЕР ----------------------------------------------------------------
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' НАЧАЛО ФАЙЛ -----------------------------------------------------------------
'------------------------------------------------------------------------------
'LineLOCKExe = PrgDirx86 + " ENTERPRISE " + BaseParam + DBPath + _
'" /N""" + InfoBasesAdminName + """ /P" + InfoBasesAdminPass + _
'" /DumpIB" + FullPathName + "/CЗавершитьРаботуПользователей /UC" + LockPermissionCode
'LineBAKExe = PrgDirx86 + " CONFIG " + BaseParam + DBPath + _
'" /N""" + InfoBasesAdminName + """ /P" + InfoBasesAdminPass + _
'" /DumpIB" + FullPathName + " /UC" + LockPermissionCode + " /DisableStartupMessages"
'LineUNLOCKExe = PrgDirx86 + " ENTERPRISE " + BaseParam + DBPath + _
'" /N""" + InfoBasesAdminName + """ /P" + InfoBasesAdminPass + _
'" /DumpIB" + FullPathName + "/CРазрешитьРаботуПользователей /UC" + LockPermissionCode
'Set Programs1c = WshShell.Exec(LineLOCKExe)
'Do While Programs1c.Status = 0
' WScript.Sleep 1000
'Loop
'Set Programs1c = WshShell.Exec(LineBAKExe)
'Do While Programs1c.Status = 0
' WScript.Sleep 1000
'Loop
'Set Programs1c = WshShell.Exec(LineUNLOCKExe)
'------------------------------------------------------------------------------
' КОНЕЦ ФАЙЛ ------------------------------------------------------------------
'------------------------------------------------------------------------------ [/more]
Добавлено:
Скрипт разблокировки базы после неудачного копирования 8.2 (создайте файл с расширением vbs)
Например unlock.vbs
Set oShell = WScript.CreateObject("WScript.Shell")
Set Programs1c = oShell.Exec("""C:\Program Files\1cv82\8.2.18.109\bin\1cv8.exe"" ENTERPRISE /S""serv1cnew:1541\test1"" /CРазрешитьРаботуПользователей /UCКодРазрешения")
Доброго дня, не подскажите ли.
Есть bak и md файлы, можно ли, имея только их, восстановить базу 1С 7.7? И как именно.
Бекап восстановил в SQL Mngmnt Studio (2008), далее положил MD в папку, добавил базу в список баз 1С, захожу в конфигуратор - выбираю тип базы SQL, ввожу параметры подключения к SQL в конфигураторе, при входе в режиме предприятия сообщение "Не определены параметры базы данных, воспользуйтесь конфигуратором"
upd
завел пользовтеля, появился DDS файл, но теперь при входе в режиме Предприятие пишет ошибку "нарушена структура таблицы 1sjourn", вероятно, потому что MD файл отличается от того, который был на момент сохранения бекапа (предполагаю что он новее). Можно как-нибудь обойти?
Есть bak и md файлы, можно ли, имея только их, восстановить базу 1С 7.7? И как именно.
Бекап восстановил в SQL Mngmnt Studio (2008), далее положил MD в папку, добавил базу в список баз 1С, захожу в конфигуратор - выбираю тип базы SQL, ввожу параметры подключения к SQL в конфигураторе, при входе в режиме предприятия сообщение "Не определены параметры базы данных, воспользуйтесь конфигуратором"
upd
завел пользовтеля, появился DDS файл, но теперь при входе в режиме Предприятие пишет ошибку "нарушена структура таблицы 1sjourn", вероятно, потому что MD файл отличается от того, который был на момент сохранения бекапа (предполагаю что он новее). Можно как-нибудь обойти?
viacheslav_panov
Цитата:
а ты указал параметры базы данных sql в конфигураторе?
Цитата:
без создания пользователей должна база открываться если бэкап скуля и мд одной даты, даже не важно, лишь бы структура базы не менялась после бэкапирования.
Цитата:
завел пользовтеля, появился DDS файл, но теперь при входе в режиме Предприятие пишет ошибку "нарушена структура таблицы 1sjourn", вероятно, потому что MD файл отличается от того, который был на момент сохранения бекапа (предполагаю что он новее). Можно как-нибудь обойти?
а ты указал параметры базы данных sql в конфигураторе?
Цитата:
завел пользовтеля, появился DDS файл, но теперь при входе в режиме Предприятие пишет ошибку "нарушена структура таблицы 1sjourn"
без создания пользователей должна база открываться если бэкап скуля и мд одной даты, даже не важно, лишь бы структура базы не менялась после бэкапирования.
viacheslav_panov
Цитата:
Удали файл .DDS, в конфигураторе добавь новый справочник(любой), примени изменения.
Также ругалось и у меня, при восстановлении bak с другим md.
Цитата:
нарушена структура таблицы 1sjourn"
Удали файл .DDS, в конфигураторе добавь новый справочник(любой), примени изменения.
Также ругалось и у меня, при восстановлении bak с другим md.
Народ, как можно организовать резервное копирование комплексной конфигурации 1С 7.7 завязанной на Microsoft SQL 2000 и все это поднято на Windows Server 2003 R2 Enterprise?
Возможно ли сохранить cf файл конфигурации не имея административных прав?
Diabolik
Цитата:
средствами самого сиквела + акронис
Цитата:
Народ, как можно организовать резервное копирование комплексной конфигурации 1С 7.7 завязанной на Microsoft SQL 2000 и все это поднято на Windows Server 2003 R2 Enterprise?
средствами самого сиквела + акронис
alpopo если в файловой, то с помощью Tool 1CD
Добрый день! Подскажите чайнику, при выполнении обработки ошибка-различаются версии клиента и сервера.
Одновременно на одном сервере работают 8.1 и 8.2
Что делать?
Добавлено:
http://forum.ru-board.com/topic.cgi?forum=8&topic=6319&start=141&limit=1&m=1 вот эта обработка (естественно , со своими параметрами)
Одновременно на одном сервере работают 8.1 и 8.2
Что делать?
Добавлено:
http://forum.ru-board.com/topic.cgi?forum=8&topic=6319&start=141&limit=1&m=1 вот эта обработка (естественно , со своими параметрами)
Предыдущая тема: Объединить диски разных компов в сети в один виртуальный
Форум Ru-Board.club — поднят 15-09-2016 числа. Цель - сохранить наследие старого Ru-Board, истории становления российского интернета. Сделано для людей.