Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Пересылка файлов Эксель из аутлука в папку на локальном комп - Мир MS Excel

Старая форма входа
  • Страница 1 из 2
  • 1
  • 2
  • »
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Пересылка файлов Эксель из аутлука в папку на локальном комп (Макросы/Sub)
Пересылка файлов Эксель из аутлука в папку на локальном комп
t330 Дата: Среда, 01.04.2020, 02:48 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Всем доброго времени суток!

Есть ежедневный отчет в виде файлов Эксель , который падает в яндекс-почту, ну или в Outlook на компе завязанный на Яндекс-почту.
Эти файлы приходится вручную перетаскивать в папку на компе или в облаке , чтобы Power BI тоже ежедневно забирал их оттуда и обновлял свои дэшборды.

Кто знает, как сделать так, чтобы эти Эксель файлы приходящие в аутлук сразу при получении автоматом падали в специальную папку на компе ? Чтобы не перетаскивать их вручную?

Отчеты всегда приходят с одного адреса test@test.ru
Приходят раз в сутки.
Аутлук всегда открыт на компе.

Нашел тему с похожей задачей, но здесь нет файлы копируются из выбранных вручную писем.
http://www.excelworld.ru/forum/3-14270-1

Помогите пожалуйста допились код, чтобы файлы автоматом падали в папку при получении от адресата с адресом test@test.ru
 
Ответить
СообщениеВсем доброго времени суток!

Есть ежедневный отчет в виде файлов Эксель , который падает в яндекс-почту, ну или в Outlook на компе завязанный на Яндекс-почту.
Эти файлы приходится вручную перетаскивать в папку на компе или в облаке , чтобы Power BI тоже ежедневно забирал их оттуда и обновлял свои дэшборды.

Кто знает, как сделать так, чтобы эти Эксель файлы приходящие в аутлук сразу при получении автоматом падали в специальную папку на компе ? Чтобы не перетаскивать их вручную?

Отчеты всегда приходят с одного адреса test@test.ru
Приходят раз в сутки.
Аутлук всегда открыт на компе.

Нашел тему с похожей задачей, но здесь нет файлы копируются из выбранных вручную писем.
http://www.excelworld.ru/forum/3-14270-1

Помогите пожалуйста допились код, чтобы файлы автоматом падали в папку при получении от адресата с адресом test@test.ru

Автор - t330
Дата добавления - 01.04.2020 в 02:48
doober Дата: Среда, 01.04.2020, 18:22 | Сообщение № 2
Группа: Друзья
Ранг: Ветеран
Сообщений: 947
Репутация: 323 ±
Замечаний: 0% ±

Excel 2010
Кто знает

Я.Создайте правило на обработку писем в аутлуке и в нем сохраняйте вложения в нужные папки.


 
Ответить
Сообщение
Кто знает

Я.Создайте правило на обработку писем в аутлуке и в нем сохраняйте вложения в нужные папки.

Автор - doober
Дата добавления - 01.04.2020 в 18:22
t330 Дата: Среда, 01.04.2020, 20:19 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Я.Создайте правило на обработку писем в аутлуке и в нем сохраняйте вложения в нужные папки.


Так можно только сохранять письма полученные от test@test.ru в папку в самом аутлуке.
Сохранять именно вложения из писем полученных от test@test.ru и именно в папку НА компе типа c:/user/test не получится.
 
Ответить
Сообщение
Я.Создайте правило на обработку писем в аутлуке и в нем сохраняйте вложения в нужные папки.


Так можно только сохранять письма полученные от test@test.ru в папку в самом аутлуке.
Сохранять именно вложения из писем полученных от test@test.ru и именно в папку НА компе типа c:/user/test не получится.

Автор - t330
Дата добавления - 01.04.2020 в 20:19
doober Дата: Среда, 01.04.2020, 21:50 | Сообщение № 4
Группа: Друзья
Ранг: Ветеран
Сообщений: 947
Репутация: 323 ±
Замечаний: 0% ±

Excel 2010
и именно в папку НА компе типа c:/user/test не получится

Кто Вам такое сказал.
Я немного не правильно написал по правилу.
Создается правило обработки писем и назначается этому правилу скрипт.


 
Ответить
Сообщение
и именно в папку НА компе типа c:/user/test не получится

Кто Вам такое сказал.
Я немного не правильно написал по правилу.
Создается правило обработки писем и назначается этому правилу скрипт.

Автор - doober
Дата добавления - 01.04.2020 в 21:50
t330 Дата: Среда, 01.04.2020, 22:48 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Я немного не правильно написал по правилу.
Создается правило обработки писем и назначается этому правилу скрипт.


Извините , не понимаю о чем речь...

У меня только такие правила есть. Там вообще нет возможности назначит рукописный макрос в качестве какого -то правила.
[img][/img]


Сообщение отредактировал t330 - Среда, 01.04.2020, 23:40
 
Ответить
Сообщение
Я немного не правильно написал по правилу.
Создается правило обработки писем и назначается этому правилу скрипт.


Извините , не понимаю о чем речь...

У меня только такие правила есть. Там вообще нет возможности назначит рукописный макрос в качестве какого -то правила.
[img][/img]

Автор - t330
Дата добавления - 01.04.2020 в 22:48
t330 Дата: Среда, 01.04.2020, 22:56 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Скомпоновал код для записи экселевских файлов из писем , которые приходят на АККАУНТ name@name.ru
от отправителя c адресом info@test.ru и падают в аутлуке в папку под номером 11

Вроде всё верно, но почему-то выскакивает вот такое сообщение.
Подскажите пожалуйста что не так?

[vba]
Код


Option Explicit

Public Sub saveAttachtoDisk() 'объявляем процедуру записи вложений писем в папку на компьютере.
  Const myFolder As String = "C:\Test\" ' в константу MyFolder пишем путь куда сохранять вложения из писем,при этом название конечной папки info@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 = "info@test.ru" ' от этого отправителя нужно сохранять файлы
  AccountName = "name@name.ru" ' в этой учетной записи будем просматривать папки
  
  If Dir(myFolder & SenderMail, vbDirectory) = "" Then  ' проверяем , если на компе каталог
    MkDir myFolder & SenderMail  ' и если папки info@test.ru нет, то создаем её в каталоге C:\Test\
  End If
  Savefolder = myFolder & SenderMail ' записываем в переменную путь к нашей целевой папке на компьютере  ( C:\Test\ info@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(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
                      End If
                    Next
          
          End If
       End If
    Next i
  End If
  Next f

  
End Sub

[/vba]

[img][/img]


Сообщение отредактировал t330 - Среда, 01.04.2020, 22:58
 
Ответить
СообщениеСкомпоновал код для записи экселевских файлов из писем , которые приходят на АККАУНТ name@name.ru
от отправителя c адресом info@test.ru и падают в аутлуке в папку под номером 11

Вроде всё верно, но почему-то выскакивает вот такое сообщение.
Подскажите пожалуйста что не так?

[vba]
Код


Option Explicit

Public Sub saveAttachtoDisk() 'объявляем процедуру записи вложений писем в папку на компьютере.
  Const myFolder As String = "C:\Test\" ' в константу MyFolder пишем путь куда сохранять вложения из писем,при этом название конечной папки info@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 = "info@test.ru" ' от этого отправителя нужно сохранять файлы
  AccountName = "name@name.ru" ' в этой учетной записи будем просматривать папки
  
  If Dir(myFolder & SenderMail, vbDirectory) = "" Then  ' проверяем , если на компе каталог
    MkDir myFolder & SenderMail  ' и если папки info@test.ru нет, то создаем её в каталоге C:\Test\
  End If
  Savefolder = myFolder & SenderMail ' записываем в переменную путь к нашей целевой папке на компьютере  ( C:\Test\ info@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(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
                      End If
                    Next
          
          End If
       End If
    Next i
  End If
  Next f

  
End Sub

[/vba]

[img][/img]

Автор - t330
Дата добавления - 01.04.2020 в 22:56
doober Дата: Среда, 01.04.2020, 23:50 | Сообщение № 7
Группа: Друзья
Ранг: Ветеран
Сообщений: 947
Репутация: 323 ±
Замечаний: 0% ±

Excel 2010
К папке C:\Test\ info@test.ru есть доступ
Если да, то пока не готов ответить


 
Ответить
СообщениеК папке C:\Test\ info@test.ru есть доступ
Если да, то пока не готов ответить

Автор - doober
Дата добавления - 01.04.2020 в 23:50
t330 Дата: Четверг, 02.04.2020, 00:03 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
К папке C:\Test\ info@test.ru есть доступ


Если руками туда файлы кидать, то доступ есть...
 
Ответить
Сообщение
К папке C:\Test\ info@test.ru есть доступ


Если руками туда файлы кидать, то доступ есть...

Автор - t330
Дата добавления - 02.04.2020 в 00:03
doober Дата: Четверг, 02.04.2020, 01:08 | Сообщение № 9
Группа: Друзья
Ранг: Ветеран
Сообщений: 947
Репутация: 323 ±
Замечаний: 0% ±

Excel 2010
[vba]
Код

Savefolder = myFolder & SenderMail ' Это папка а не путь к файлу
myItem.Attachments.Item(a).SaveAsFile Savefolder
' Так должно быть
myItem.Attachments.Item(a).SaveAsFile Savefolder & "/file.xlsx"
[/vba]
У Вас имя файла не правильно указано


 
Ответить
Сообщение[vba]
Код

Savefolder = myFolder & SenderMail ' Это папка а не путь к файлу
myItem.Attachments.Item(a).SaveAsFile Savefolder
' Так должно быть
myItem.Attachments.Item(a).SaveAsFile Savefolder & "/file.xlsx"
[/vba]
У Вас имя файла не правильно указано

Автор - doober
Дата добавления - 02.04.2020 в 01:08
t330 Дата: Четверг, 02.04.2020, 02:54 | Сообщение № 10
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
У Вас имя файла не правильно указано


Точно. Спасибо
Заменил Вашу строчку на
[vba]
Код


myItem.Attachments.Item(a).SaveAsFile Savefolder & "/" & myItem.Attachments.Item(a).FileName
[/vba]

чтобы все вложения копировались и не затирались...

Не знаете, как этот код внедрить в аутлук, чтоб он всегда срабатывал при приходе нового письма от info@test.ru ?
 
Ответить
Сообщение
У Вас имя файла не правильно указано


Точно. Спасибо
Заменил Вашу строчку на
[vba]
Код


myItem.Attachments.Item(a).SaveAsFile Savefolder & "/" & myItem.Attachments.Item(a).FileName
[/vba]

чтобы все вложения копировались и не затирались...

Не знаете, как этот код внедрить в аутлук, чтоб он всегда срабатывал при приходе нового письма от info@test.ru ?

Автор - t330
Дата добавления - 02.04.2020 в 02:54
doober Дата: Четверг, 02.04.2020, 10:46 | Сообщение № 11
Группа: Друзья
Ранг: Ветеран
Сообщений: 947
Репутация: 323 ±
Замечаний: 0% ±

Excel 2010
Назначьте на правило получение почты скрипт RuleSave


 
Ответить
СообщениеНазначьте на правило получение почты скрипт RuleSave

Автор - doober
Дата добавления - 02.04.2020 в 10:46
t330 Дата: Четверг, 02.04.2020, 13:55 | Сообщение № 12
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Назначьте на правило получение почты скрипт RuleSave


У меня Аутлук 2019, поэтому долго не мог понять о каких скриптах вы говорите.

Наконец нагуглил. https://u.to/dUj6Fw
Внес в реестр изменения, чтобы эта функция создания правил со скриптами-таки появилась.

Создал правило со скриптом
Я так понял скрипт будет срабатывать только для новых сообщений от info@test.ru ?

А чтобы скачать старые сообщения в папку на c:\test\ , нужно один раз использовать мой код выше или при установке вашего правила со скриптом можно как-то заставить сработать его и для всех прошлых сообщений?



Сообщение отредактировал t330 - Четверг, 02.04.2020, 14:31
 
Ответить
Сообщение
Назначьте на правило получение почты скрипт RuleSave


У меня Аутлук 2019, поэтому долго не мог понять о каких скриптах вы говорите.

Наконец нагуглил. https://u.to/dUj6Fw
Внес в реестр изменения, чтобы эта функция создания правил со скриптами-таки появилась.

Создал правило со скриптом
Я так понял скрипт будет срабатывать только для новых сообщений от info@test.ru ?

А чтобы скачать старые сообщения в папку на c:\test\ , нужно один раз использовать мой код выше или при установке вашего правила со скриптом можно как-то заставить сработать его и для всех прошлых сообщений?


Автор - t330
Дата добавления - 02.04.2020 в 13:55
t330 Дата: Четверг, 02.04.2020, 14:05 | Сообщение № 13
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Назначьте на правило получение почты скрипт RuleSave


Вставил ваш код в модуль в аутлуке , попытался запустить, а процедуры RuleSave вообще нет в списке макросов...

Я так понимаю - это какой - то особый вид процедур , который нельзя запускать из редактора ?


Сообщение отредактировал t330 - Четверг, 02.04.2020, 14:27
 
Ответить
Сообщение
Назначьте на правило получение почты скрипт RuleSave


Вставил ваш код в модуль в аутлуке , попытался запустить, а процедуры RuleSave вообще нет в списке макросов...

Я так понимаю - это какой - то особый вид процедур , который нельзя запускать из редактора ?

Автор - t330
Дата добавления - 02.04.2020 в 14:05
doober Дата: Четверг, 02.04.2020, 14:29 | Сообщение № 14
Группа: Друзья
Ранг: Ветеран
Сообщений: 947
Репутация: 323 ±
Замечаний: 0% ±

Excel 2010
В списке макросов не будет, есть параметр для вызова процедуры.
Попробуйте проект сохранить, закрыть аутлук, потом открыть.Должно появиться
К сообщению приложен файл: NewFilm_2004021.avi (148.3 Kb)


 
Ответить
СообщениеВ списке макросов не будет, есть параметр для вызова процедуры.
Попробуйте проект сохранить, закрыть аутлук, потом открыть.Должно появиться

Автор - doober
Дата добавления - 02.04.2020 в 14:29
t330 Дата: Четверг, 02.04.2020, 14:34 | Сообщение № 15
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
В списке макросов не будет, есть параметр для вызова процедуры.
Попробуйте проект сохранить, закрыть аутлук, потом открыть.Должно появиться


Спасибо,с этим уже разобрался (отредактировал сообщения выше) ...

Могли бы еще ответить на вот этот вопрос из видео https://radikal.ru/video/YuyaMiDhrPy ? На видео пытаюсь применить правило из скрипта для всех прошлых писем, но он не срабатывает.


Сообщение отредактировал t330 - Четверг, 02.04.2020, 14:46
 
Ответить
Сообщение
В списке макросов не будет, есть параметр для вызова процедуры.
Попробуйте проект сохранить, закрыть аутлук, потом открыть.Должно появиться


Спасибо,с этим уже разобрался (отредактировал сообщения выше) ...

Могли бы еще ответить на вот этот вопрос из видео https://radikal.ru/video/YuyaMiDhrPy ? На видео пытаюсь применить правило из скрипта для всех прошлых писем, но он не срабатывает.

Автор - t330
Дата добавления - 02.04.2020 в 14:34
doober Дата: Четверг, 02.04.2020, 14:47 | Сообщение № 16
Группа: Друзья
Ранг: Ветеран
Сообщений: 947
Репутация: 323 ±
Замечаний: 0% ±

Excel 2010
В фрагмент Вашего кода вставил вызов процедуры[vba]
Код
    For i = 1 To oFolder.Items.Count  ' пробегаем циклом по каждому элементу в папке oFolder
     If oFolder.Items(i).Class = olMail Then   ' если элемент в папке oFolder - это письмо, то
        Set myItem = oFolder.Items.Item(i) ' присваиваем переменной myItem это письмо
         CopyRule myItem  '' Эта вставка
     End If
    Next i
[/vba]


 
Ответить
СообщениеВ фрагмент Вашего кода вставил вызов процедуры[vba]
Код
    For i = 1 To oFolder.Items.Count  ' пробегаем циклом по каждому элементу в папке oFolder
     If oFolder.Items(i).Class = olMail Then   ' если элемент в папке oFolder - это письмо, то
        Set myItem = oFolder.Items.Item(i) ' присваиваем переменной myItem это письмо
         CopyRule myItem  '' Эта вставка
     End If
    Next i
[/vba]

Автор - doober
Дата добавления - 02.04.2020 в 14:47
t330 Дата: Четверг, 02.04.2020, 15:07 | Сообщение № 17
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
В фрагмент Вашего кода вставил вызов процедуры


Вставил фрагмент, но в скрипт не получается вставить (видео попытки:) https://radikal.ru/video/vdCtOWn7JEa

Извиняюсь за глупы вопросы...
 
Ответить
Сообщение
В фрагмент Вашего кода вставил вызов процедуры


Вставил фрагмент, но в скрипт не получается вставить (видео попытки:) https://radikal.ru/video/vdCtOWn7JEa

Извиняюсь за глупы вопросы...

Автор - t330
Дата добавления - 02.04.2020 в 15:07
t330 Дата: Четверг, 02.04.2020, 15:55 | Сообщение № 18
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
Может вы имеете ввиду не CopyRule а RuleSave вставить?

[vba]
Код


For i = 1 To oFolder.Items.Count  ' пробегаем циклом по каждому элементу в папке oFolder
    If oFolder.Items(i).Class = olMail Then   ' если элемент в папке oFolder - это письмо, то
        Set myItem = oFolder.Items.Item(i) ' присваиваем переменной myItem это письмо
        RuleSave myItem  '' Эта вставка
    End If
    Next i

[/vba]

Тоже не особо срабатывает:
https://radikal.ru/video/t1bNQxjte57
 
Ответить
СообщениеМожет вы имеете ввиду не CopyRule а RuleSave вставить?

[vba]
Код


For i = 1 To oFolder.Items.Count  ' пробегаем циклом по каждому элементу в папке oFolder
    If oFolder.Items(i).Class = olMail Then   ' если элемент в папке oFolder - это письмо, то
        Set myItem = oFolder.Items.Item(i) ' присваиваем переменной myItem это письмо
        RuleSave myItem  '' Эта вставка
    End If
    Next i

[/vba]

Тоже не особо срабатывает:
https://radikal.ru/video/t1bNQxjte57

Автор - t330
Дата добавления - 02.04.2020 в 15:55
doober Дата: Четверг, 02.04.2020, 16:05 | Сообщение № 19
Группа: Друзья
Ранг: Ветеран
Сообщений: 947
Репутация: 323 ±
Замечаний: 0% ±

Excel 2010
По ошибке видно, что есть дубли функций.
При переносе задублировали скорее всего


 
Ответить
СообщениеПо ошибке видно, что есть дубли функций.
При переносе задублировали скорее всего

Автор - doober
Дата добавления - 02.04.2020 в 16:05
t330 Дата: Четверг, 02.04.2020, 20:17 | Сообщение № 20
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 147
Репутация: 0 ±
Замечаний: 20% ±

Excel 2016
В общем, мне так и не удалось использовать процедуру не затирания файлов RuleSave
При вставке этого скрипта http://www.excelworld.ru/forum/10-44512-294115-16-1585813610 в правила и при установке флажка применить ко всем письмам ничего не происходит...

Попытался вставить в свой код в параметры процедуры строку ( myItem as MailItem) (то есть получилось вот так: Public Sub saveAttachtoDisk( myItem as MailItem) ) ,чтобы можно было этот скрипт выбирать для создания правила.
Скрипт saveAttachtoDisk выбирать возможность появилась , но он также не работает как и RuleSave...

Хотя без этого параметра Public Sub saveAttachtoDisk() отрабатывает отлично и копирует все файлы в папку на комп , причем от нужно учетной записи и от нужного отправителя... Жаль, что приходится запускать вручную а не через правило.

[vba]
Код


Option Explicit

Public Sub saveAttachtoDisk( myItem as MailItem)  'объявляем процедуру записи вложений писем в папку на компьютере.
  Const myFolder As String = "D:\YandexDisk\YandexDisk\" ' в константу MyFolder пишем путь куда сохранять вложения из писем,при этом название конечной папки info@realtycalendar.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@realtycalendar.ru" ' от этого отправителя нужно сохранять файлы в папке D:\YandexDisk\YandexDisk\info@realtycalendar.ru
  AccountName = "sport11b@ya.ru" ' в этой учетной записи будем просматривать папки
 
  
  If Dir(myFolder & SenderMail, vbDirectory) = "" Then  ' проверяем , если на компе в каталоге D:\YandexDisk\YandexDisk\ папка info@realtycalendar.ru
    MkDir myFolder & SenderMail  ' и если папки info@realtycalendar.ru нет, то создаем её
  End If
  Savefolder = myFolder & SenderMail ' записываем в переменную путь к нашей целевой папке на компьютере  ( D:\YandexDisk\YandexDisk\ папка info@realtycalendar.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

[/vba]


Сообщение отредактировал t330 - Четверг, 02.04.2020, 20:19
 
Ответить
СообщениеВ общем, мне так и не удалось использовать процедуру не затирания файлов RuleSave
При вставке этого скрипта http://www.excelworld.ru/forum/10-44512-294115-16-1585813610 в правила и при установке флажка применить ко всем письмам ничего не происходит...

Попытался вставить в свой код в параметры процедуры строку ( myItem as MailItem) (то есть получилось вот так: Public Sub saveAttachtoDisk( myItem as MailItem) ) ,чтобы можно было этот скрипт выбирать для создания правила.
Скрипт saveAttachtoDisk выбирать возможность появилась , но он также не работает как и RuleSave...

Хотя без этого параметра Public Sub saveAttachtoDisk() отрабатывает отлично и копирует все файлы в папку на комп , причем от нужно учетной записи и от нужного отправителя... Жаль, что приходится запускать вручную а не через правило.

[vba]
Код


Option Explicit

Public Sub saveAttachtoDisk( myItem as MailItem)  'объявляем процедуру записи вложений писем в папку на компьютере.
  Const myFolder As String = "D:\YandexDisk\YandexDisk\" ' в константу MyFolder пишем путь куда сохранять вложения из писем,при этом название конечной папки info@realtycalendar.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@realtycalendar.ru" ' от этого отправителя нужно сохранять файлы в папке D:\YandexDisk\YandexDisk\info@realtycalendar.ru
  AccountName = "sport11b@ya.ru" ' в этой учетной записи будем просматривать папки
 
  
  If Dir(myFolder & SenderMail, vbDirectory) = "" Then  ' проверяем , если на компе в каталоге D:\YandexDisk\YandexDisk\ папка info@realtycalendar.ru
    MkDir myFolder & SenderMail  ' и если папки info@realtycalendar.ru нет, то создаем её
  End If
  Savefolder = myFolder & SenderMail ' записываем в переменную путь к нашей целевой папке на компьютере  ( D:\YandexDisk\YandexDisk\ папка info@realtycalendar.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

[/vba]

Автор - t330
Дата добавления - 02.04.2020 в 20:17
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Пересылка файлов Эксель из аутлука в папку на локальном комп (Макросы/Sub)
  • Страница 1 из 2
  • 1
  • 2
  • »
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!