Извлечение вложений электронной почты от даты получения - VBA

Question

Заранее спасибо за помощь!

У меня есть один код, который помогает мне извлечь все вложения электронной почты из указанной c папки электронной почты. это работает отлично. Но теперь я хочу изменить извлечение вложений электронной почты, начиная с даты, которую я ввожу в диалоговом окне (я хочу извлечь вложения электронной почты только для писем, которые я получил за последние семь дней, а не для всей папки). Ниже приведен код для вашей справки:

Sub Extract_emails()
    Dim OlApp As Object
    Dim OlMail As Object
    Dim OlItems As Object
    Dim Olfolder As Object
    Dim J As Integer
    Dim strFolder As String

    Set OlApp = GetObject(, "Outlook.Application")        
    If Err.Number = 429 Then
    Set OlApp = CreateObject("Outlook.Application")   
    End If

    strFolder = ThisWorkbook.Path & "\Extract"            
    Set Olfolder = OlApp.getnamespace("MAPI").Folders("MyEmailAddress").Folders("Inbox")
    Set OlItems = Olfolder.Items

    For Each OlMail In OlItems
    If OlMail.Attachments.Count > 0 Then
        For J = 1 To OlMail.Attachments.Count
        OlMail.Attachments.Item(J).SaveAsFile strFolder & "\" & OlMail.Attachments.Item(J).Filename
        Next J

    End If

    Set OlApp = Nothing
    Set OlMail = Nothing
    Set OlItems = Nothing
    Set Olfolder = Nothing

    Next

    MsgBox ("Done")
End Sub

Дополнительная информация

Спасибо за помощь, Тони, я добавляю дополнительную информацию.

Вы правильно угадать Мне нужно извлечь только почтовые вложения xlsx (поставщик отправляет документы Excel и PDF по почте) и сохранить их в папке. После того, как мне нужен код, чтобы открыть сохраненный Excel и скопировать данные в базу и закрыть сохраненный xlsx. Я не знаю имени файла xlsx (обычно это название нашей компании и некоторые цифры), но в каждом отчете есть «отправленные» листы, с которых я копирую данные в базу. Никто не читает эти письма, поэтому я пробую непрочитанные письма. Пожалуйста, смотрите ниже код, который работает для меня, когда я go с F8, но не работает с F5.

 Set OlApp = GetObject(, "Outlook.Application")

 If Err.Number = 429 Then
 Set OlApp = CreateObject("Outlook.Application")
 End If

 strFolder = ThisWorkbook.Path & "\Extract"
 Set Olfolder = OlApp.getnamespace("MAPI").Folders("Freight.Invoice@omega.com").Folders("Inbox")
Set OlItems = Olfolder.Items


For Each OlMail In OlItems

If OlMail.UnRead = True Then

    If OlMail.Attachments.Count > 0 Then

        For J = 1 To OlMail.Attachments.Count
        FilePath = strFolder & "\" & OlMail.Attachments.Item(J).FileName
        OlMail.Attachments.Item(J).SaveAsFile FilePath
            If Right(FilePath, 4) = "xlsx" Then

                runit FilePath
                    For I = 1 To Worksheets.Count
                        If Worksheets(I).Name = "Shipped" Then
                            Worksheets("Shipped").Activate
                            Set wsCopy = Worksheets("Shipped")
                            Set wsDest = Workbooks("Extract 
 emails.xlsm").Worksheets("DATA")
                            lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, 
 "B").End(xlUp).Row
                            lDestLastRow = wsDest.Cells(wsDest.Rows.Count, 
"B").End(xlUp).Offset(1).Row
                            wsCopy.Range("B4:K" & lCopyLastRow).Copy _
                            wsDest.Range("B" & lDestLastRow)

                            Worksheets("Shipped").Activate
                            ActiveWorkbook.Close savechanges:=False


                        End If
                    Next

            End If

        Next J

     End If

End If


Next

For Each OlMail In OlItems

If OlMail.UnRead = True Then
OlMail.UnRead = False
DoEvents
OlMail.Save

End If

Set OlApp = Nothing
Set OlMail = Nothing
Set OlItems = Nothing
Set Olfolder = Nothing

Next


MsgBox ("Done")


End Sub 


Sub runit(FilePath As String)

Dim Shex As Object
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long


Set Shex = CreateObject("Shell.Application")
Shex.Open (FilePath)

End Sub

Answer 1

Это учебник, а не прямой ответ на ваш вопрос. Я покрываю все, что вам нужно знать. Я считаю, что вы найдете этот подход более полезным, чем ответ «запустите этот код, и он будет работать». Надеюсь, я все объяснил адекватно. При необходимости возвращайтесь с вопросами.

Вам необходимо сравнить полученное время электронной почты с самой старой требуемой датой. Вы говорите, что намереваетесь ввести самую старую требуемую дату, а также хотите указать последние семь дней. Там может быть альтернатива. Введите следующие команды (кроме комментариев) в вашем непосредственном окне.

? now()                                The current date and time
? datevalue(now())                     The current date      
? dateadd("d",-7,now())                Seven days before now
? dateadd("d",-7,datevalue(now()))     Seven days ago
? dateadd("ww",-1,datevalue(now()))    One week ago

Дает ли вам какое-либо из этих выражений желаемую дату? В DateAdd «d» и «ww» - это интервалы, где «d» означает дни, а «ww» означает недели. Существуют и другие значения, такие как «w», означающие дни недели. Поэкспериментируйте, если одно из этих выражений дает вам почти то, что вам нужно.

Другие возможности включают установку категории или пользовательского свойства при сохранении вложений.

Если вы еще этого не сделали, откройте Ваша рабочая тетрадь и редактор VBA. Нажмите [Инструменты], затем [Ссылки…]. Находится ли отметка «Библиотека объектов Microsoft Outlook nn.n» в верхней части списка? Примечание. «Nn.n» зависит от используемой версии Office. Если эта библиотека не указана и не отмечена, прокрутите вниз, пока не найдете ее, и щелкните на маленьком окошке, чтобы отметить ее. Это дает вашей книге доступ к элементам данных Outlook, поэтому вам не нужно указывать столько объектов.

Теперь создайте новый модуль и скопируйте в него приведенный ниже код. Если вы запустите макрос Demo(), вы получите вывод, подобный следующему:

Oldest additions to Inbox
  [14/12/2019 18:21:21]  [28/12/2019 05:05:00]  [08/01/2020 18:37:09]  [28/03/2019 16:16:12]  [21/03/2019 14:00:08]
  [14/06/2018 21:02:34]  [03/02/2020 09:29:38]  [06/03/2020 17:03:50]  [11/03/2020 13:43:33]  [12/03/2020 00:07:53]
  [13/03/2020 08:46:58]  [13/03/2020 17:31:23]  [14/03/2020 03:42:53]  [14/03/2020 08:07:35]  [14/03/2020 08:58:11]
  [15/03/2020 19:43:16]  [16/03/2020 16:48:40]  [16/03/2020 20:39:58]  [17/03/2020 11:14:29]  [18/03/2020 01:43:37]

Newest additions to Inbox
  [18/03/2020 01:43:37]  [17/03/2020 11:14:29]  [16/03/2020 20:39:58]  [16/03/2020 16:48:40]  [15/03/2020 19:43:16]
  [14/03/2020 08:58:11]  [14/03/2020 08:07:35]  [14/03/2020 03:42:53]  [13/03/2020 17:31:23]  [13/03/2020 08:46:58]
  [12/03/2020 00:07:53]  [11/03/2020 13:43:33]  [06/03/2020 17:03:50]  [03/02/2020 09:29:38]  [14/06/2018 21:02:34]
  [21/03/2019 14:00:08]  [28/03/2019 16:16:12]  [08/01/2020 18:37:09]  [28/12/2019 05:05:00]  [14/12/2019 18:21:21]

Newest emails in Inbox
  [20/03/2020 12:16:47]  [20/03/2020 00:00:14]  [19/03/2020 17:51:21]  [19/03/2020 17:06:38]  [19/03/2020 10:19:36]
  [18/03/2020 16:21:25]  [18/03/2020 01:43:37]  [17/03/2020 11:14:29]  [16/03/2020 20:39:58]  [16/03/2020 16:48:40]
  [15/03/2020 19:43:16]  [14/03/2020 08:58:11]  [14/03/2020 08:07:35]  [14/03/2020 03:42:53]  [13/03/2020 17:31:23]
  [13/03/2020 08:46:58]  [12/03/2020 00:07:53]  [11/03/2020 13:43:33]  [06/03/2020 17:03:50]  [03/02/2020 09:29:38]

Oldest emails in Inbox
  [14/06/2018 21:02:34]  [21/03/2019 14:00:08]  [28/03/2019 16:16:12]  [14/12/2019 18:21:21]  [28/12/2019 05:05:00]
  [08/01/2020 18:37:09]  [03/02/2020 09:29:38]  [06/03/2020 17:03:50]  [11/03/2020 13:43:33]  [12/03/2020 00:07:53]
  [13/03/2020 08:46:58]  [13/03/2020 17:31:23]  [14/03/2020 03:42:53]  [14/03/2020 08:07:35]  [14/03/2020 08:58:11]
  [15/03/2020 19:43:16]  [16/03/2020 16:48:40]  [16/03/2020 20:39:58]  [17/03/2020 11:14:29]  [18/03/2020 01:43:37]

Замечания:

У меня есть Dim OutApp As New Outlook.Application. «Новый» говорит, что создайте ссылку, а не просто создайте элемент данных для ссылки. Это означает, что мне не нужно GetObject или CreateObject. Outlook одновременно допускает только одно вхождение, поэтому мое «Новое» или ваш CreateObject будут ссылаться на существующее вхождение или создавать новое в случае необходимости. У меня также есть OutApp.Quit в конце. Это закрывает Outlook независимо от того, был ли он уже открыт. Я не использую Outlook при использовании книг Excel для доступа к Outlook, поэтому хочу, чтобы Outlook был закрыт. Если вам не безразлично, используйте код «Получить» или «Создать», но запись была успешной, чтобы вы знали, требуется ли «Выход».

Я назвал свой элемент данных OutApp вместо olApp. Outlook использует префикс «ol» для своих констант, поэтому я избегаю этого префикса, если мое имя совпадает с одним из имен Outlook.

Я использовал Session вместо GetNamespace("MAPI"). Это просто разные способы достижения одного и того же эффекта.

ItemsInbox - это «Коллекция»; что другие языки называют «списком». Коллекция похожа на массив, за исключением того, что вы можете добавлять новые записи перед любыми существующими записями, в середине или после любых существующих записей. Любые существующие записи могут быть удалены.

Outlook добавляет новые электронные письма в конце коллекции. Таким образом, если вы читаете от первого до последнего, первое письмо будет тем, которое было в папке «Входящие» дольше всего. Если вы читаете от последнего к первому, первое электронное письмо будет добавлено в папку «Входящие» последним. Это говорит о том, что вы можете читать с последнего на первое и сначала просматривать самые последние электронные письма, и вы можете остановиться, когда достигнете электронного письма вне допустимого диапазона. Однако, если вы переместите старое письмо из папки «Входящие» в другую папку, а затем вернете его обратно, оно не будет возвращено в прежнее положение; вместо этого он будет добавлен в конец.

В приведенном ниже макросе я сначала перечисляю ReceivedTime из двадцати писем от первого к последнему, затем от последнего к первому. Вы можете заметить, что некоторые не совпадают.

Затем я перечисляю ReceivedTime из двадцати электронных писем после сортировки по ReceivedTime в порядке убывания, затем в порядке возрастания.

Изучите четыре блока даты. В частности, обратите внимание на разные последовательности. Я полагаю, что код за третьим блоком дат будет наиболее подходящим для вас.

Я думаю, что я все рассмотрел, но, как я уже сказал, я вернусь, если возникнут вопросы, и я исправлю все недостатки.

Option Explicit

  ' Needs reference to "Microsoft Outlook n.nn Object Library"
  ' where n.nn depends on the version of Outlook you are using.

Sub Demo()

  Dim FldrInbox As Outlook.Folder
  Dim InxICrnt As Long
  Dim InxIMax As Long
  Dim ItemsInbox As Outlook.Items
  Dim NumOnLine As Long
  Dim OutApp As New Outlook.Application

  Set FldrInbox = OutApp.Session.Folders("a.j.dallimore@xxxxxxx.com").Folders("Inbox")

  Set ItemsInbox = FldrInbox.Items

  If ItemsInbox.Count > 20 Then
    InxIMax = 20
  Else
    InxIMax = ItemsInbox.Count
  End If

  Debug.Print "Oldest additions to Inbox"
  NumOnLine = 0
  For InxICrnt = 1 To InxIMax
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  Debug.Print "Newest additions to Inbox"
  NumOnLine = 0
  For InxICrnt = InxIMax To 1 Step -1
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  ItemsInbox.Sort "ReceivedTime", True
  Debug.Print "Newest emails in Inbox"
  NumOnLine = 0
  For InxICrnt = 1 To InxIMax
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  ItemsInbox.Sort "ReceivedTime", False
  Debug.Print "Oldest emails in Inbox"
  NumOnLine = 0
  For InxICrnt = 1 To InxIMax
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  Set ItemsInbox = Nothing
  OutApp.Quit
  Set OutApp = Nothing

End Sub

Пересмотренное требование

Каждую неделю или около того вы получаете электронное письмо от поставщика, содержащее счет в формате PDF и XLSX. Правило Outlook распознает эту электронную почту и перемещает ее в выделенную папку. Ваша команда не заинтересована в PDF-версии. Рабочая книга XLSX не имеет постоянного имени. Тем не менее, он постоянно содержит лист «Отправлено», который содержит данные, которые будут полезны для вашей команды. В настоящее время вы не будете пытаться обрабатывать эти данные с помощью макроса, но вы хотели бы, чтобы они были объединены в вашу собственную рабочую книгу, чтобы ее можно было легко просмотреть командой. В настоящее время желаемый формат:

Columns B to K of row 4+ of worksheet “Shipped” for week starting 1Mar20
    :    :    :    :    :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 8Mar20
    :    :    :    :    :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 15Mar20
    :    :    :    :    :

Рассмотренные идеи по выполнению требования

Если бы вы спросили несколько месяцев go, я бы предложил связать макрос с правилом с помощью «Run a script». Microsoft решила, что «Запустить скрипт» опасно и больше не доступно по умолчанию. Существует интерактивная справка, которая объясняет, как сделать «Выполнить скрипт» доступной, но я предлагаю вам подождать, пока вы не станете более опытным, прежде чем пытаться это сделать.

Я бы предложил пересмотренный формат для консолидированных данных:

Data from email received 2Mar20 9:10
   Entire contents of worksheet “Shipped”
Data from email received 9Mar20 9:30
   Entire contents of worksheet “Shipped”
Data from email received 16Mar20 9:20
   Entire contents of worksheet “Shipped”

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

Макрос необязательно должен быть в той же книге, что и данные. Я обычно держу макрос и данные отдельно для этого типа задачи. Данные регулярно обновляются, но макрос обновляется только изредка. Например, я загружаю свои банковские выписки каждый месяц и объединяю их в непрерывный отчет за несколько лет. Я изменяю макрос только тогда, когда они меняют формат загрузки.

Вам не нужен код, который распознает электронную почту, например, путем тестирования свойства UnRead, потому что интересующая электронная почта будет последней в выделенном папки. Существует вероятность, что вы вызовете макрос до того, как придет новое письмо, поэтому макрос просматривает электронное письмо на прошлой неделе. Если он проверит последний заголовок в консолидированной рабочей таблице, он узнает, что у него старая книга и может выйти без внесения изменений.

Следующее мое предложение. Не беспокойтесь, если вы не знаете, как реализовать некоторые из моих идей, потому что я знаю, как это сделать.

У вас есть две рабочие книги с такими именами, как «Макросы консолидации V02.xlsm» и «Консолидированные данные V25.xlsx» , Всякий раз, когда поступает новый счет, вы открываете последнюю книгу макросов консолидации и запускаете макрос консолидации. Макросы можно запускать автоматически при открытии рабочей книги, но я рекомендую на время оставить это. Макрос открывает последнюю книгу данных и отмечает дату самого последнего добавления. Он получает доступ к Outlook, находит последнюю электронную почту счета-фактуры и сверяет ее дату с датой самого последнего добавления. Если дата последнего сообщения электронной почты о счете позже, чем последнее добавление, макрос завершается. Если дата удовлетворительная, макрос находит вложение XLSX и сохраняет его в dis c. Он открывает эту рабочую книгу, проверяет рабочую таблицу «Отправлено» и добавляет ее содержимое в конец рабочей таблицы «Отправлено» в самой последней таблице консолидированных данных и сохраняет рабочую книгу со следующим номером версии.

Вы заметите, что у меня есть номер версии для каждой книги. Во время моей работы я видел слишком много бедствий, потому что люди не сохраняли новую версию, когда обновляли файл. Я могу сбросить номера версий, если вы не хотите их.

Считаете ли вы, что выше соответствует вашим требованиям?

Answer 2

Я закончил тестирование системы, которую я предложил в своем первоначальном ответе. Это не совсем то же самое, по причинам, которые я объясню позже, но это соответствует во всех важных деталях. Я публикую его как новый ответ, чтобы не было путаницы.

Чтобы проверить это, я создал несколько книг, которые я назвал Test1, Test2, Test3 и так далее. В каждой рабочей тетради я создал рабочую таблицу «Отправлено». Каждый из этих листов имел различное количество строк и столбцов. Каждая ячейка содержала «TRC», где T - номер теста, R - строка, а C - столбец. Эти значения позволили очень легко проверить, правильно ли были скопированы данные из вложений в консолидированную таблицу. После удаления большинства строк, чтобы структура была видна, результат консолидации был:

Вы можете видеть, что мой код может объединять все строки и все столбцы из столько электронных писем, сколько требуется. Мои электронные письма не разделены на неделю, но это не важно.

Я рекомендую вам попробовать мой макрос как есть. Затем вы можете обсудить внешний вид со своими коллегами, а затем мы можем обсудить, как изменить мой макрос в соответствии с вашими требованиями.

Создайте новую папку dis c и в ней создайте две новые рабочие книги: одну обычную (xlsx) и один макрос с поддержкой (xlsm).

Назовите обычную книгу «Консолидированные данные.xlsx». В нем переименуйте рабочую таблицу по умолчанию как «Отправлено».

Имя рабочей книги с поддержкой макросов не имеет значения, так же как и имя рабочей таблицы. В редакторе VBA создайте три модуля и назовите их «LibExcel», «LibOutlook» и «ModConsolidate». Именование модулей не является обязательным, но разделение макросов по назначению и именование модулей для этих целей значительно облегчают жизнь.

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

Модуль "ModConsolidate" предназначен для кода, который я написал специально для ваших требований. Модуль "LibExcel" предназначен для кода из моей библиотеки подпрограмм, связанных с Excel. Модуль "LibOutlook" предназначен для кода из моей библиотеки связанных с Outlook подпрограмм.

Когда я заканчиваю проект, я просматриваю его, чтобы увидеть, есть ли какой-нибудь код, который я мог бы использовать sh для повторного использования. Если есть, я извлекаю его и сохраняю в «PERSONAL.XLSB», который я использую в качестве своей библиотеки. Любой макрос, сохраненный в этой книге, доступен для всех других книг. Не беспокойтесь сегодня, но когда у вас будет свободное время, посмотрите, как создать "PERSONAL.XLSB". Когда вы его создадите, переместите в него модули «LibExcel» и «LibOutlook». В «LibExcel» у меня есть подпрограммы, чтобы найти последнюю использованную строку и столбец листа и проверить, существует ли именованный лист. В «LibOutlook» у меня есть процедуры для открытия и закрытия экземпляра Outlook из Excel.

Когда я запускаю проект, я просматриваю свою библиотеку на предмет процедур, которые могут быть подходящими. При необходимости подпрограмма будет расширена, чтобы обеспечить функциональность, которая мне не была нужна раньше. В результате у меня есть библиотека полезных функций, которые становятся все более мощными и большими по мере завершения каждого проекта.

Я сказал, что у меня будут номера версий в книге, которую я создал для вас. К сожалению, макросы, которые обрабатывают эту и связанные с ней функции, слишком велики для отправки в переполнение стека.

Этот код должен go в LibExcel:

' Routines useful with Excel

Option Explicit
Public Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
                          ByRef ColLast As Long)

  ' Sets RowLast and ColLast to the last row and column with a value
  ' in worksheet Wsht

  ' The motivation for coding this routine was the discovery that Find by
  ' previous row found a cell formatted as Merge and Center but Find by
  ' previous column did not.
  ' I had known the Find would miss merged cells but this was new to me.

  '   Dec16  Coded
  ' 31Dec16  Corrected handling of UserRange
  ' 15Feb17  SpecialCells was giving a higher row number than Find for
  '          no reason I could determine.  Added code to check for a
  '          value on rows and columns above those returned by Find
  ' 25Jun17  Found column with value about that found by Find

  Dim ColCrnt As Long
  Dim ColLastFind As Long
  Dim ColLastOther As Long
  Dim ColLastTemp As Long
  Dim ColLeft As Long
  Dim ColRight As Long
  Dim Rng As Range
  Dim RowIncludesMerged As Boolean
  Dim RowBot As Long
  Dim RowCrnt As Long
  Dim RowLastFind As Long
  Dim RowLastOther As Long
  Dim RowLastTemp As Long
  Dim RowTop As Long

  With Wsht

    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
    If Rng Is Nothing Then
      RowLastFind = 0
      ColLastFind = 0
    Else
      RowLastFind = Rng.Row
      ColLastFind = Rng.Column
    End If

    Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
    If Rng Is Nothing Then
    Else
      If RowLastFind < Rng.Row Then
        RowLastFind = Rng.Row
      End If
      If ColLastFind < Rng.Column Then
        ColLastFind = Rng.Column
      End If
    End If

    Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
      RowLastOther = 0
      ColLastOther = 0
    Else
      RowLastOther = Rng.Row
      ColLastOther = Rng.Column
    End If

    Set Rng = .UsedRange
    If Rng Is Nothing Then
    Else
      If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
        RowLastOther = Rng.Row + Rng.Rows.Count - 1
      End If
      If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
        ColLastOther = Rng.Column + Rng.Columns.Count - 1
      End If
    End If

    If RowLastFind < RowLastOther Then
      ' Higher row found by SpecialCells or UserRange
      Do While RowLastOther > RowLastFind
        ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
        If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
          Debug.Assert False
          ' Is this possible
          ' Row after RowLastFind has value
          RowLastFind = RowLastOther
          Exit Do
        End If
        RowLastOther = RowLastOther - 1
      Loop
    ElseIf RowLastFind > RowLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    RowLast = RowLastFind

    If ColLastFind < ColLastOther Then
      ' Higher column found by SpecialCells or UserRange
      Do While ColLastOther > ColLastFind
        RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
        If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
          'Debug.Assert False
          ' Column after ColLastFind has value
          ' Possible causes:
          '   * Find does not recognise merged cells
          '   ' Find does not examine hidden cells
          ColLastFind = ColLastOther
          Exit Do
        End If
        ColLastOther = ColLastOther - 1
      Loop
    ElseIf ColLastFind > ColLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    ColLast = ColLastFind

  End With

End Sub
Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String) As Boolean

  ' Returns True if Worksheet WshtName exists within
  '  * if Wbk Is Nothing the workbook containing the macros
  '  * else workbook Wbk

  ' 21Aug16  Coded by Tony Dallimore
  ' 14Feb17  Coded alternative routine that cycled through the existing worksheets
  '          matching their names against WshtName to check if use of "On Error Resume Next"
  '          was the faster option. I needed to call the routines 6,000,000 times each to
  '          get an adequate duration for comparison. This version took 33 seconds while
  '          the alternative took 75 seconds.
  ' 21Feb20  Added "As Boolean" to declaration. Do not understand how routine worked
  '          without it.

  Dim WbkLocal As Workbook
  Dim Wsht As Worksheet

  If Wbk Is Nothing Then
    Set WbkLocal = ThisWorkbook
  Else
    Set WbkLocal = Wbk
  End If

  Err.Clear
  On Error Resume Next
  Set Wsht = WbkLocal.Worksheets(WshtName)
  On Error GoTo 0
  If Wsht Is Nothing Then
    WshtExists = False
  Else
    WshtExists = True
  End If

End Function

Этот код должен go в LibOutlook

' Routines useful with Outlook.

Option Explicit
Public Sub OutAppClose(ByRef OutApp As Outlook.Application, ByVal Created As Boolean)

  ' If Created is True, quit the current instance if Outlook.

  If Created Then
    OutApp.Quit
  End If

  Set OutApp = Nothing

End Sub
Public Function OutAppGetCreate(ByRef Created As Boolean) As Outlook.Application

  ' Return a reference to the Outlook Application.
  ' Set Created to True if the reference is to a new application and to
  ' False if the reference is to an existing application.

  ' If Nothing is returned, the routine has been unable to get or create a reference.

  ' Only one instance of Outlook can be running.  CreateObject("Outlook.Application")
  ' will return a reference to the existing instance if one is already running or
  ' will start a new instance if one is not running.  The disadvantage of using
  ' CreateObject, is the caller does not know if Outlook was running so does not know
  ' whether or not to quit Outlook when it has finished using Outlook.  By setting
  ' Created, this routine allows the caller to only quit if this is appropriate.

  Set OutAppGetCreate = Nothing
  On Error Resume Next
  Set OutAppGetCreate = GetObject(, "Outlook.Application")
  On Error GoTo 0
  If OutAppGetCreate Is Nothing Then
    On Error Resume Next
    Set OutAppGetCreate = CreateObject("Outlook.Application")
    On Error GoTo 0
    If OutAppGetCreate Is Nothing Then
      Call MsgBox("I am unable to access Outlook", vbOKOnly)
      Exit Function
    End If
    Created = True
  Else
    Created = False
  End If

End Function

Этот код должен go в ModConsolidate:

Option Explicit

  ' * Need reference to "Microsoft Outlook nn.n Object Library"
  '   where nn.n depends on the version of Office being used.
  ' * Needs reference to "Microsoft Scripting Runtime"

  Const HeaderForData As String = "Data from email received"
  Const WbkConName As String = "Consolidated Data.xlsx"
  Const WshtName As String = "Shipped"  ' Also used for name of workbooks
Sub ConsolidateDataFromShippedWshts() ()

  ' Outlook used "ol" as a prefix for its constants. I do not use the same
  ' prefix to avoid a clash.
  Dim OutApp As Outlook.Application
  Dim OutAppCreated As Boolean

  Dim ColConLast As Long             ' Last column of worksheet "Shipped" in consolidated workbook
  Dim ColSrcLast As Long             ' Last column of worksheet "Shipped" in source workbook
  Dim DateLatestExisting As Date     ' Date of last block of data in consolidated workbook
  Dim DateStr As String              ' Date extracted from header row
  Dim FldrShipped As Outlook.Folder  ' Outlook Folder containing source emails
  Dim InxA As Long                   ' Index into attachments
  Dim InxI As Long                   ' Index into mail items
  Dim InxW As Long                   ' Into into WbkSrcNames
  Dim ItemsShipped As Items          ' Items in source folder
  Dim Path As String                 ' Disc folder containing workbooks
  Dim Rng As Range                   ' Various uses
  Dim RowConCrnt As Long             ' Current row of worksheet "Shipped" in consolidated workbook
  Dim RowConLast As Long             ' Last row of worksheet "Shipped" in consolidated workbook
  Dim RowSrcLast As Long             ' Last row of worksheet "Shipped" in source workbook
  Dim WbkCon As Workbook             ' Consolidated workbook
  Dim WbkMacros As Workbook          ' This workbook
  Dim WbkSrc As Workbook             ' Workbook extracted from email
  Dim WbkSrcName As String           ' Name of workbook extracted from email
  Dim WbkSrcNameDates As Collection  ' Collection of the names and dates of workbooks extracted from emails
  Dim WshtCon As Worksheet           ' Worksheet "Shipped" in consolidated workbook
  Dim WshtSrc As Worksheet           ' Worksheet "Shipped" in source workbook

  Application.ScreenUpdating = False

  Set WbkMacros = ThisWorkbook

  Path = WbkMacros.Path

  ' ### Change if you want a different name for consolidated workbook
  Set WbkCon = Workbooks.Open(Path & "\" & WbkConName)
  Set WshtCon = WbkCon.Worksheets(WshtName)

  ' Find last used row of consolidated worksheet
  Call FindLastRowCol(WshtCon, RowConLast, ColConLast)

  If RowConLast = 0 Then
    ' No data added yet
    DateLatestExisting = 0
  Else
    ' Search up for header for last block of data added
    With WshtCon
      Set Rng = .Columns(1).Find( _
                      What:=HeaderForData, After:=.Cells(RowConLast + 1, 1), _
                      LookIn:=xlValues, LookAt:=xlPart, _
                      SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                      MatchCase:=False, SearchFormat:=False)
      If Rng Is Nothing Then
        Debug.Assert False
        ' It should not be possible to be here.  Either the worksheet is empty
        ' and RowColLast = 0 or one or more blocks of data, each with a header,
        ' have been added.  It appears the worksheet is not as it should be.
        DateLatestExisting = 0
      Else
        DateStr = Mid$(.Cells(Rng.Row, 1).Value, Len(HeaderForData) + 2)
        If IsDate(DateStr) Then
          DateLatestExisting = DateValue(DateStr) + TimeValue(DateStr)
        Else
          Debug.Assert False
          ' It should not be possible to be here.  The text after HeaderForData
          ' should be a valid date. It appears the worksheet is not as it should be.
          DateLatestExisting = 0
        End If
      End If

    End With
  End If

  Set OutApp = OutAppGetCreate(OutAppCreated)

  If OutApp Is Nothing Then
    ' OutAppGetCreated() failed.  The user has already been told.
    Exit Sub
  End If

  ' ### Change to access folder where you store these emails
  Set FldrShipped = OutApp.Session.Folders("MyName@MyIsp").Folders("Test")

  ' Create list of items in folder sorted by ReceivedTime
  Set ItemsShipped = FldrShipped.Items
  ItemsShipped.Sort "ReceivedTime", True

  Set WbkSrcNameDates = New Collection

  ' Read items, newest first, until reach an item at or before DateLatestExisting
  ' Save xlsx attachment, if any, and record names in WbkSrcNames
  For InxI = 1 To ItemsShipped.Count
    If TypeName(ItemsShipped(InxI)) = "MailItem" Then
      If ItemsShipped(InxI).ReceivedTime <= DateLatestExisting Then
        ' No more unprocessed emails
        Exit For
      End If
      ' Save Xlsx attachment, if any
      For InxA = 1 To ItemsShipped(InxI).Attachments.Count
        If LCase(Right$(ItemsShipped(InxI).Attachments(InxA).FileName, 5)) = ".xlsx" Then
          ' Have found required attachment. Save with name based on date received
          WbkSrcName = WshtName & " " & Format(ItemsShipped(InxI).ReceivedTime, "yymmdd hhmmss") & ".xlsx"
          ItemsShipped(InxI).Attachments(InxA).SaveAsFile Path & "\" & WbkSrcName
          WbkSrcNameDates.Add VBA.Array(WbkSrcName, ItemsShipped(InxI).ReceivedTime)
          Exit For
        End If
      Next
    End If
  Next

  Call OutAppClose(OutApp, OutAppCreated)

  If WbkSrcNameDates.Count = 0 Then
    ' No new emails with xlsx attachments
    WbkCon.Close SaveChanges:=False
    Call MsgBox("No new emails containing an xlsx attachment", vbOKOnly)
    Set WshtCon = Nothing
    Set WbkCon = Nothing
    Set WbkMacros = Nothing
    Exit Sub
  End If

  ' WbkSrcNameDates contains the names and received dates of the new workbooks
  ' with the newest first.
  ' Extract names in reverse order (oldest first) and add contents of worksheet
  ' "Shipped" to bottom of worksheet "Shipped" of consolidated workbook

  For InxW = WbkSrcNameDates.Count To 1 Step -1
    Set WbkSrc = Workbooks.Open(Path & "\" & WbkSrcNameDates(InxW)(0))
    If WshtExists(WbkSrc, WshtName) Then
      ' Worksheet "Shipped" exists
      Set WshtSrc = WbkSrc.Worksheets(WshtName)
      Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)
      RowConCrnt = RowConLast + 1   ' Advance to first free row
      With WshtCon.Cells(RowConCrnt, 1)
        .Value = HeaderForData & " " & Format(WbkSrcNameDates(InxW)(1), "d-mmm-yy h:mm:ss")
        .Font.Bold = True
      End With
      RowConCrnt = RowConCrnt + 1
      With WshtSrc
        .Range(.Cells(1, 1), .Cells(RowSrcLast, ColSrcLast)).Copy _
                      Destination:=WshtCon.Cells(RowConCrnt, 1)
      End With
      RowConLast = RowConCrnt + RowSrcLast - 1
    End If

    WbkSrc.Close SaveChanges:=False
  Next

  ' Position cursor to header for latest data
  Application.ScreenUpdating = True
  WshtCon.Activate
  WshtCon.Cells(RowConLast - RowSrcLast, 1).Select
  Application.Goto ActiveCell, True
  WbkCon.Close SaveChanges:=True

  Set WshtCon = Nothing
  Set WbkCon = Nothing
  Set WbkMacros = Nothing

End Sub

В верхней части ModConsolidate говорится, что ему нужны ссылки на «Библиотеку объектов Microsoft Outlook nn.n», где nn.n зависит от используемой версии Office и «Microsoft Scripting Runtime». Если вы не уверены, что это значит, спросите, и я добавлю объяснение.

Строка 173 ModConsolidate - Set FldrShipped = OutApp.Session.Folders("MyName@MyIsp").Folders("Test"). Это относится к папке Outlook, в которую я поместил тестовые письма. Замените мою папку Outlook на папку с этими сообщениями в вашей системе. Поместите в эту папку столько писем, сколько у вас есть.

Запуск макроса ConsolidateDataFromShippedWshts(). Этот макрос будет:

• Открыть книгу «Консолидированные данные.xlsx»
• Проверить лист «Отправлено» и обнаружить, что он пуст.
• Открыть Outlook, если еще не открыть.
• Откройте папку Outlook и извлеките рабочую книгу из каждого сообщения электронной почты, поскольку лист «Отправлено» пуст. Рабочие книги будут сохранены с именем «Отправлено yymmdd hhmmss.xlsx». Если бы «Отправленный» лист не был пустым, он извлек бы рабочие книги только из новых писем.
• Закройте Outlook, если он не был открыт.
• Откройте каждую из новых рабочих книг по очереди и добавьте содержимое их листа «Отправлено» на лист «Отправлено» в «Консолидированные данные.xlsx».

Я тщательно протестировал макрос ConsolidateDataFromShippedWshts(), но только с моими поддельными рабочими книгами и электронными письмами. Он должен работать должным образом, если я неправильно понял характер ваших рабочих книг и электронных писем. Если что-то пойдет не так, опишите мне проблему, и я постараюсь определить причину.

Если все работает, как ожидалось. Просмотрите «Consolidated Data.xlsx» и обсудите это со своими коллегами. Пока вы это делаете, я начну добавлять больше информации о моем макросе к этому ответу.

Answer 3

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

Option Explicit

Sub Extract_attachments_recent_emails()

    ' code for Excel

    Dim olApp As Object
    Dim olMail As Object
    Dim olItems As Object
    Dim olfolder As Object

    Dim J As Long

    Dim strFolder As String

    Dim ageDays As Long
    Dim strFilter As String
    Dim resItems As Object

    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Set olApp = CreateObject("Outlook.Application")
    End If

    strFolder = ThisWorkbook.Path & "\Extract"
    Set Olfolder = olApp.GetNamespace("MAPI").Folders("MyEmailAddress").Folders("Inbox")

    Set olItems = olfolder.items

    ' save time with hardcoded number
    'ageDays = 7

    ' be flexible with InputBox
    ageDays = InputBox("ageDays", "Input age of oldest mail in days", "7")

    strFilter = "[ReceivedTime]>'" & Format(Date - ageDays, "DDDDD HH:NN") & "'"

    Set resItems = olItems.Restrict(strFilter)

    For Each olMail In resItems

        If olMail.Attachments.Count > 0 Then
            For J = 1 To olMail.Attachments.Count
                OlMail.Attachments.Item(J).SaveAsFile strFolder & "\" & OlMail.Attachments.Item(J).Filename
            Next J
        End If

    Set olMail = Nothing

    Next

    MsgBox ("Done")

End Sub