Заебся делать руками, а главное помнить про это каждую неделю....
Поставил задачу. Решил. Счастлив.
Заебся делать руками, а главное помнить про это каждую неделю....
Поставил задачу. Решил. Счастлив.
Задача: собрать файлы с датой создания <= 7 дней, скопировать в папку, заархивировать папку и выслать архив по эл. почте.
Решение скрипт:
Dim objFolder
Dim colFiles ' list of files
Dim objFile ' file
adress1 = "Иванов Петя " ' E-Mail отправителя
adress2 = "PavelIvanov@mylo.ru" ' E-Mail получателя
' собираем имя папки из текущей даты
segodnya = now()
mm = Month(segodnya)
dd = Day(segodnya)
if Month(segodnya) < 10 then
mm = "0"&Month(segodnya)
end if
if Day(segodnya) < 10 then
dd = "0"&Day(segodnya)
end if
' создаем папку по дате 20191010
datefolder = "111\"&Year(segodnya)&mm&dd
With CreateObject("Scripting.FileSystemObject")
.Createfolder datefolder
End With
' копируем файлы в папку для сжатия
Const OverwriteExisting = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.CopyFile "RECEIVE\*" , datefolder, OverwriteExisting
' Папка Статистики
statfolder = "%dir%\STS\"
Set objFolder = objFSO.GetFolder(statfolder)
Set colFiles = objFolder.Files
' дата для проверки
datestat7 = now()-7
mm7 = Month(datestat7)
dd7 = Day(datestat7)
if Month(datestat7) < 10 then
mm7 = "0"&Month(datestat7)
end if
if Day(datestat7) < 10 then
dd7 = "0"&Day(datestat7)
end if
datestat = dd7&"."&mm7&"."&Year(datestat7)
' копируем файлы по дате моложе или равно 7 дней
For Each objFile in colFiles
if CDate(datestat) < objFile.DateLastModified then
objFSO.CopyFile objFile.Path, datefolder&"\", OverwriteExisting
end if
Next
' Архивация
Set objShell = CreateObject("WScript.Shell")
NameArx = Year(segodnya)&mm&dd&".zip"
str7zarx = "7z a -r "&NameArx&" "&datefolder
objShell.run str7zarx
'WScript.Quit
' Оптравляем почту.........
FileMail = "%dir%"&NameArx
Const cdoSendUsingPickup = 1
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = "Сататистика ////////"
objMessage.From = adress1
objMessage.To = adress2
objMessage.TextBody = "Очередная порция статистики ......"
CreateObject("WScript.Shell").Popup FileMail, 2, "Title"
objMessage.AddAttachment(FileMail)
' Секция настроек SMTP сервера для отправки почты.
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
' Имя или IP адрес SMTP Server
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "10.10.10.101"
' Тип используемой авторизации, NONE, Basic (Base64 encoded), NTLM
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = NONE
' SMTP server
'objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.yandex.ru"
' Авторизация на SMTP server
'objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "secret.abc"
' Пароль SMTP server
'objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "*********"
' Порт SMTP Server port (обычно 25, но может быть и другим)
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' Использование SSL для соединения (False или True)
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
' Время ожидания соединения с почтовым сервером
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
' Сохранить настройки CDO для отправки сообщения
objMessage.Configuration.Fields.Update
' Отправить созданное почтовое сообщение с вложением по указанному адресу
objMessage.Send
'Wscript.Quit
' Удаляем папку с файлами статистики за период и перемещаем архив
objFSO.Deletefolder datefolder
objFSO.MoveFile NameArx, "111\"
Wscript.Quit
Добавить комментарий