скрипт vbs vbscript бекап backup базы 1с 77 WebDav

скрипт vbs vbscript бекап backup базы 1с 77  WebDav



по мотивам SPV_Ed с форума ru-board
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"

Const indnt = "                   " 'space indent for log for strings without time
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 indnt & " Размер архивируемой директории: " & strDataPath & " - " & Round(objFolder.Size / 1048576,2) & " Mb", strLogFile

' Запуск программы-архиватора
if PassForArc <> "" then hpPassForArc = "-hp"&PassForArc end if

WshShell.Run "%comspec% /a /c echo &" & chr(34) & strPathToArchiver & "Rar.exe" & chr(34) & " a -ep1 -r -se -rr10p -m5 -dh  "& hpPassForArc &" -x@" & strExcFile & " -ilog:" & strArcErrLogFile & " " & strPathArchiveLocal & strDirDaily & strDataDailyFileName & " " & strDataPath & "*", 0, True

' Вычисление размера созданного архива
If objFSO.FileExists(strPathArchiveLocal & strDirDaily & strDataDailyFileName & ".rar") = true Then
   Set objTestFile = objFSO.GetFile(strPathArchiveLocal & strDirDaily & strDataDailyFileName & ".rar")
   WriteTextFiles indnt & " Размер созданного суточного архива: " & objTestFile & " - " & Round(objTestFile.Size / 1048576,2) & " Mb", strLogFile
Else
   WriteTextFiles indnt & " ОШИБКА: Файл: " & 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
   x=0
   For Each File In objFiles
      Result = Abs(DateDiff(intrvl, Now, File.DateCreated))
      If Result > strPeriod-1 Then
         strDeleteLog = strDeleteLog + indnt & " Удален файл: " & File.Path & " от: " & File.DateCreated & VbCrLf
         File.Delete
   x=x+1
      End If
   Next
   DeleteOldFiles = strDeleteLog & indnt & " удалено " & x & " файлов"
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 ""
 '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 ""
 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 &"..."
 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 & "well Done." & vbcrlf & 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 & "false." & vbcrlf & Now & " ОШИБКА: Файл: " & sfileName & " НЕ скопирован в " & strUrlUploadDestWithoutFilename
  Else
   'wscript.echo  "PUT: Request Failed.  Results = " & xmlhttp.status & ": " & xmlhttp.statusText
   sendFile2webdav = False
   strCopyLog = strCopyLog & "false!" & vbcrlf & 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 & " удаляю файлы WebDav из "& strPath & "..."
    arrListFiles = webDavListOnlyFiles(strPath)
 x=0
    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"
  x=x+1
  wddofRet = webDavDeleteFile(strPath&File(0))
        if wddofRet = true then
   strDeleteLog = vbcrlf & now & " Удален файл: " & File(0) & " от: " & File(1)
        elseif wddofRet = false then
   strDeleteLog = vbcrlf & now & " Файл НЕ удален: " & File(0) & " от: " & File(1)
  else
   strDeleteLog = vbcrlf & now &" "&  wddofRet
  End If
    End If
    Next
    webDavDeleteOldFiles = strDeleteLog & vbcrlf & indnt & " удалено " & x & " файлов."
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 ""
 XMLreq.send ""
 '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