Страницы: 1
RSS
Пересылка файлов Эксель из аутлука в папку на локальном комп
 
Всем доброго времени суток!

Есть ежедневный отчет в виде файлов Эксель , который падает в яндекс-почту, ну или в 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() срабатывал бы как правило в аутлуке при приходе новой почты.

Я попытался добавить параметр внутрь процедуры  Sub saveAttachtoDisk( myItem as MailItem) ) ,чтобы можно было этот скрипт выбирать для создания правила в аутлуке  (как вот тут рекомендуют https://docs.microsoft.com/ru-ru/previous-versions/office/troubleshoot/office-developer/create-scrip... ).
Скрипт стало можно выбирать, но тогда макрос не срабатывает. Ничего никуда не копирует....

Не могу понять, как из моего макроса сделать рабочий скрипт для правила в аутлуке.
Объясните плиз кто разбирается.
Спасибо.

Код
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
Изменено: t330 - 02.04.2020 20:45:33
 
Вопрос с Excel совершенно не связан
 
В Outlook на приход письма реагирует событие Application_NewMail и Application_NewMailEx
Для примера:
Код
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)


ПыСы: Событие в модуле "ThisOutlookSession"
В коде пропишите проверку на прочтено письмо или нет, если не прочтенное (свойство Item - .UnRead = True),
то копируете файлы и делаете его прочтенным (свойство Item - .UnRead = False),
если прочитано (свойство Item - .UnRead = False), то пропускаете.
Изменено: Александр Макаров - 02.04.2020 22:31:11
 
vikttur,
формально-буквенная связь с Эксель есть, я же копирую только экселевские файлы из аутлука в папку на компе:)

Шучу, не сердитесь.  
 
Цитата
t330 написал:
я же копирую только экселевские файлы
А если бы копировали графические - написали бы на форум по Фотошопу?
 
Юрий М, я же написал, что шучу?

К тому же, на этом форуме я видел вопросы по макросам относящимся к Аутлуку. Почему претензия ко мне?
 
Александр Макаров, спасибо за наводку.
Пойду допиливать дальше. Что получится выложу тут  
 
t330, Вы лучше почитайте #3.
А претензии к ВАМ потому, что ВЫ разместили свою тему не на профильном форуме.
 
Тогда лучше берите событие "Application_NewMail"
Код
Private Sub Application_NewMail()

и применительно к вашему коду:
в строку
Код
 If myItem.SenderEmailAddress = SenderMail Then ' если в этом письме адрес отправителя равен SenderMail , то 
добавить проверку на прочтение
например
Код
 If myItem.SenderEmailAddress = SenderMail and myItem.unread=true Then ' если в этом письме адрес отправителя равен SenderMail и письмо не прочитано , то

и внутри этого If ... Then добавить строку
Код
 myItem.unread=False 
 
Юрий М, прошу извинить. Больше размещать тут ничего не буду.
 
Александр Макаров,

Всё работает!
Сделал как вы сказали.

Код основного модуля:
Код
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.
 
Попробуйте другое событие:
Код
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)


Единственное может не cрабатывать в версиях MSOffice 2007
Изменено: Александр Макаров - 03.04.2020 16:00:30
Страницы: 1
Наверх