Есть ежедневный отчет в виде файлов Эксель , который падает в яндекс-почту, ну или в Outlook на компе завязанный на Яндекс-почту. Эти файлы приходится вручную перетаскивать в папку на компе или в облаке , чтобы Power BI тоже ежедневно забирал их оттуда и обновлял свои дэшборды.
Кто знает, как сделать так, чтобы эти Эксель файлы приходящие в аутлук сразу при получении автоматом падали в специальную папку на компе (в данном случае адрес папки D:\YandexDisk\YandexDisk\ info_mail.ru ) ? Чтобы не перетаскивать их вручную?
Отчеты всегда приходят с одного адреса info_mail.ru и падают в папку под номером 11 в учетной записи account_ya.ru (здесь и далее знак _ подразумевает @ )
Отчеты приходят на конкретную учетную запись с именем account_ya.ru (в аутлуке есть несколько учетных записей, но вложения нужно копировать , только из писем приходящих на конкретно одну учетную запись)
Аутлук всегда открыт на компе.
Помогите пожалуйста допились код, чтобы файлы автоматом падали в папку при получении нового письма от info_mail.ru на аккаунт account_ya.ru
Внизу рабочий макрос Sub saveAttachtoDisk(), который я скомпановал из разных кусков и он прекрасно работает , если его запускать руками. (второй макрос Sub Учетки_и_папки() - это чисто вспомогательный макрос от уважаемого The Priest для определения номеров папок и номеров учеток в аутлуке)
Нужно сделать так , чтобы мой макрос Sub saveAttachtoDisk() срабатывал бы как правило в аутлуке при приходе новой почты.
Не могу понять, как из моего макроса сделать рабочий скрипт для правила в аутлуке. Объясните плиз кто разбирается. Спасибо.
Код
Option Explicit
Public Sub saveAttachtoDisk() 'объявляем процедуру записи вложений писем в папку на компьютере.
Const myFolder As String = "D:\YandexDisk\YandexDisk\" ' в константу MyFolder пишем путь куда сохранять вложения из писем,при этом название конечной папки info_mail.ru совпадает с адресом отправителя
Dim myItem As Outlook.MailItem
Dim oFolder As Outlook.folder
Dim Account As Outlook.NameSpace
Dim a As Integer ' вспомогательная переменная для разных нужд
Dim i As Integer ' вспомогательная переменная для разных нужд
Dim f As Integer 'вспомогательная переменная для разных нужд
Dim SenderMail As String 'переменная для обозначения имени отправителя из писем которого мы будем вытаскиваеть вложения и записывать из в папку на компьютере
Dim Savefolder As String ' переменная для записи пути к папке , куда скидываем наши вложения из аутлука
Dim AccountName As String ' переменная для записи имени Учетной записи в аутлуке, где мы ищем наши письма с вложениями
SenderMail = "info_mail.ru" ' от этого отправителя нужно сохранять файлы в папке D:\YandexDisk\YandexDisk\info_mail.ru
AccountName = "account_ya.ru" ' в этой учетной записи будем просматривать папки
If Dir(myFolder & SenderMail, vbDirectory) = "" Then ' проверяем , если на компе в каталоге D:\YandexDisk\YandexDisk\ папка info_mail.ru
MkDir myFolder & SenderMail ' и если папки info_mail.ru нет, то создаем её
End If
Savefolder = myFolder & SenderMail ' записываем в переменную путь к нашей целевой папке на компьютере ( D:\YandexDisk\YandexDisk\ папка info_mail.ru )
'Debug.Print savefolder
Set Account = Application.GetNamespace("MAPI") ' получаем доступ к учетным записям в аутлук
'Set inboxFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' получаем коллекцию писем в папке Входящие (включая подпапки) в аутлук
For f = 1 To Account.Folders.Count ' пробегаем циклом по всем учетным записям в аутлуке
If Account.Folders(f).Name = AccountName Then ' если имя учетной записи равно AccountName , то
Set oFolder = Account.Folders(f).Folders(11) ' получаем коллекцию писем в учетной записи AccountName в папке номер 11
For i = 1 To oFolder.Items.Count ' пробегаем циклом по каждому элементу в папке oFolder
If oFolder.Items(i).Class = olMail Then ' если элемент в папке oFolder - это письмо, то
Set myItem = oFolder.Items.Item(i) ' присваиваем переменной myItem это письмо
If myItem.SenderEmailAddress = SenderMail Then ' если в этом письме адрес отправителя равен SenderMail , то
For a = 1 To myItem.Attachments.Count
If myItem.Attachments.Item(a).fileName Like "*.xl*" Then
myItem.Attachments.Item(a).SaveAsFile Savefolder & "/" & myItem.Attachments.Item(a).fileName
End If
Next
End If
End If
Next i
End If
Next f
End Sub
'Процедура показывает все учетные записи и все папки в них
Sub Учетки_и_папки()
Dim x, xx
Dim oNspace As Outlook.NameSpace
Set oNspace = Application.GetNamespace("MAPI")
For x = 1 To oNspace.Folders.Count
Debug.Print oNspace.Folders(x).Name & " ==> " & x
For xx = 1 To oNspace.Folders(x).Folders.Count
Debug.Print vbTab & oNspace.Folders(x).Folders(xx).Name & " ==> " & xx
Next
Debug.Print "============== "
Next
End Sub
В Outlook на приход письма реагирует событие Application_NewMail и Application_NewMailEx Для примера:
Код
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
ПыСы: Событие в модуле "ThisOutlookSession" В коде пропишите проверку на прочтено письмо или нет, если не прочтенное (свойство Item - .UnRead = True), то копируете файлы и делаете его прочтенным (свойство Item - .UnRead = False), если прочитано (свойство Item - .UnRead = False), то пропускаете.
If myItem.SenderEmailAddress = SenderMail Then ' если в этом письме адрес отправителя равен SenderMail , то
добавить проверку на прочтение например
Код
If myItem.SenderEmailAddress = SenderMail and myItem.unread=true Then ' если в этом письме адрес отправителя равен SenderMail и письмо не прочитано , то
Option Explicit
Public Sub saveAttachtoDisk() 'объявляем процедуру записи вложений писем в папку на компьютере.
Const myFolder As String = "D:\YandexDisk\YandexDisk\" ' в константу MyFolder пишем путь куда сохранять вложения из писем,при этом название конечной папки sender_test.ru совпадает с адресом отправителя
Dim myItem As Outlook.MailItem
Dim oFolder As Outlook.folder
Dim Account As Outlook.NameSpace
Dim a As Integer ' вспомогательная переменная для разных нужд
Dim i As Integer ' вспомогательная переменная для разных нужд
Dim f As Integer 'вспомогательная переменная для разных нужд
Dim SenderMail As String 'переменная для обозначения имени отправителя из писем которого мы будем вытаскивает вложения и записывать из в папку на компьютере
Dim Savefolder As String ' переменная для записи пути к папке , куда скидываем наши вложения из аутлука
Dim AccountName As String ' переменная для записи имени Учетной записи в аутлуке, где мы ищем наши письма с вложениями
SenderMail = "sender_test.ru" ' от этого отправителя нужно сохранять файлы в папке D:\YandexDisk\YandexDisk\sender_test.ru
AccountName = "account_user.ru" ' в этой учетной записи будем просматривать папки
If Dir(myFolder & SenderMail, vbDirectory) = "" Then ' проверяем , если на компе в каталоге D:\YandexDisk\YandexDisk\ папка sender_test.ru
MkDir myFolder & SenderMail ' и если папки sender_test.ru нет, то создаем её
End If
Savefolder = myFolder & SenderMail ' записываем в переменную путь к нашей целевой папке на компьютере ( D:\YandexDisk\YandexDisk\ папка sender_test.ru )
'Debug.Print savefolder
Set Account = Application.GetNamespace("MAPI") ' получаем доступ к учетным записям в аутлук
'Set inboxFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' получаем коллекцию писем в папке Входящие (включая подпапки) в аутлук
For f = 1 To Account.Folders.Count ' пробегаем циклом по всем учетным записям в аутлуке
If Account.Folders(f).Name = AccountName Then ' если имя учетной записи равно AccountName , то
Set oFolder = Account.Folders(f).Folders(2) ' получаем коллекцию писем в учетной записи AccountName в папке номер 11
For i = 1 To oFolder.Items.Count ' пробегаем циклом по каждому элементу в папке oFolder
If oFolder.Items(i).Class = olMail Then ' если элемент в папке oFolder - это письмо, то
Set myItem = oFolder.Items.Item(i) ' присваиваем переменной myItem это письмо
If myItem.SenderEmailAddress = SenderMail And myItem.UnRead = True Then ' если в этом письме адрес отправителя равен SenderMail и письмо не прочитано , то
For a = 1 To myItem.Attachments.Count
If myItem.Attachments.Item(a).fileName Like "*.xl*" Then
myItem.Attachments.Item(a).SaveAsFile Savefolder & "/" & myItem.Attachments.Item(a).fileName
End If
Next
myItem.UnRead = False ' отмечаем письмо как прочитанное, чтобы не просматривать его в следущей итерации цикла
End If
End If
Next i
End If
Next f
End Sub
'Процедура показывает все учетные записи и все папки в них
Sub Учетки_и_папки()
Dim x, xx
Dim oNspace As Outlook.NameSpace
Set oNspace = Application.GetNamespace("MAPI")
For x = 1 To oNspace.Folders.Count
Debug.Print oNspace.Folders(x).Name & " ==> " & x
For xx = 1 To oNspace.Folders(x).Folders.Count
Debug.Print vbTab & oNspace.Folders(x).Folders(xx).Name & " ==> " & xx
Next
Debug.Print "============== "
Next
End Sub
Код внутри ThisOutloksession
Код
Private Sub Application_NewMail()
Call saveAttachtoDisk
End Sub
Александр Макаров, Единственный минус такого решения - это то, что даже когда программа аутлук запущена на компе, но само окно не активно, то когда приходят новые письма, макрос события не реагирует. В итоге, в аутлуке видно , что новое письмо с вложением пришло, оно имеет статус "Не прочтенное" , но вложения из этого письма не копируются в папку на компе, так как макрос не запустился из-за того, что окно аутлука не активно.
Приходится активировать окно аутлука и ждать пока придет какое-нибудь новое письмо, что запустился макрос.
Код
Private Sub Application_NewMail()
Call saveAttachtoDisk
End Sub.