С сервера подгружаться выгрузки с определенным названием датой и временем. время выгрузки в сетевую папку рандомное т.е. последний 4 символа неизвестный.
.файл с сервера выгружается один с уникальным названием
код примера с прикреплением нескольких файлов. тут с условием если вложение не пусто то поиск следующих вложений. список вложений сократил чтоб не был очень длинный код
Код |
---|
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1543.xml" |
суть полного кода при пк врубается по времени через 5 мин срабатывает макрос который отправляет сообщение с вложением а затем вырубается пк
скидывал первичный код так как одно вложение с неизвестными последними 4 символами
Код |
---|
Sub Send_Mail_1()
Dim objOutlookApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
Application.ScreenUpdating = False
On Error Resume Next
'пробуем подключиться к Outlook, если он уже открыт
Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear 'Outlook закрыт, очищаем ошибку
If objOutlookApp Is Nothing Then
Set objOutlookApp = CreateObject("Outlook.Application")
End If
'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть)
' [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии]
'objOutlookApp.Session.Logon "profile","1234",False, True
Set objMail = objOutlookApp.CreateItem(0) 'создаем новое сообщение
'если не получилось создать приложение или экземпляр сообщения - выходим
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
sTo = "" 'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
sSubject = "Автоотправка tns" 'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
sBody = "Добрый день! прилагаю выгрузку tns. Excel-VBA ежедневная автоматическая отправка на данное сообщение просьба не отвечать. Обновление: файл check.txt необходим для подхвата нескольких файлов" 'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
sAttachment = "C:\1\check.txt" 'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
'создаем сообщение
With objMail
.To = sTo 'адрес получателя
.CC = "" 'адрес для копии avsemashko@oilmurman.ru
.BCC = "" 'адрес для скрытой копии
.Subject = sSubject 'тема сообщения
.Body = sBody 'текст сообщения
'.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
If sAttachment <> "" Then
If Dir(sAttachment, 16) <> "" Then
.attachments.Add sAttachment 'просто вложение
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1544.xml"
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1545.xml"
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1546.xml"
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1543.xml"
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1547.xml"
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1144.xml"
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1145.xml"
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1146.xml"
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1147.xml"
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1153.xml"
'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
End If
End If
.Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
End With |
это решение если несколько файлов но имя так же полностью прописанно