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