Используйте VBA в Excel, чтобы найти электронную почту Outlook с указанными c ключевыми словами в строке темы и вложения

Question

Используя макрос в Excel, я пытаюсь найти в Outlook самое последнее электронное письмо с «Blue Recruit Req Data» в строке темы, однако в строке темы будут дополнительные слова, поэтому нужно искать любую строку темы который содержит эту строку, но не совсем соответствует ей. Кроме того, когда обнаруживается электронное письмо со строкой «Blue Recruit Req Data» в строке темы, мне нужно убедиться, что к нему есть вложение. Если строка темы найдена, а электронное письмо содержит вложение, я хочу сохранить тему и полученную дату в переменных и сравнить их с предыдущей темой и датой, хранящимися в файле Excel, в котором запущен макрос. Если строки темы не совпадают, а дата письма позже даты последнего сохранения в файле Excel, то я хочу сохранить это вложение в папке. У меня возникают проблемы с тем, что он не находит никаких писем, содержащих в теме сообщения «Blue Recruit Req Data», но я знаю, что в моем Outlook есть несколько писем с этой фразой в строке темы. Есть предложения по поводу того, что я неправильно кодирую или чего не хватает?

Sub CheckEmail_BlueRecruit()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim olAp As Object, olns As Object, olInb As Object
Dim olItm As Object, olAtch As Object, olMail As Object
'Outlook Variables for email
Dim sSubj As String, dtRecvd As String
Dim oldSubj As String, olddtRecvd As String



Sheets("Job Mapping").Visible = True
Sheets("CC Mapping").Visible = True
Sheets("Site Mapping").Visible = True
Sheets("Historical Blue Recruit Data").Visible = True
Sheets("Historical HRT Data").Visible = False
Sheets("Combined Attrition Data").Visible = True

Sheets.Add Before:=Sheets(1)

'Designate ECP Facilities Model file as FNAME
myPath = ThisWorkbook.Path
MainWorkbook = ThisWorkbook.Name

Range("A1").Select
ActiveCell.FormulaR1C1 = myPath

'designate file path for Attrition Files
    FacModPath = Cells(1, 1).Value
    Sheets(1).Delete


'Get Outlook Instance
Set olAp = GetObject(, "Outlook.application")
Set olns = olAp.GetNamespace("MAPI")
Set olInb = olns.GetDefaultFolder(6)
Set olMail = olInb.Items.Restrict("[Subject] = ""*Blue Recruit Req Data*""")

'Chec if there are any matching emails
If Not (olMail Is Nothing) Then

    For Each olItm In olMail
        If myItem.Attachments.Count <> 0 Then
            dtRecvd = olItm.ReceivedTime
            sSubj = olItm.Subject
            oldSubj = Sheets("CC Mapping").Range("M2").Value
            olddtRecvd = Sheets("CC Mapping").Range("M3").Value
            If sSubj = oldSubj Or dtRecvd <= olddtRecvd Then
                MsgBox "No new Blue Recruit data files to load."
                Exit Sub
            Else
                Range("M2").Select
                ActiveCell.FormulaR1C1 = sSubj
                Range("M3").Select
                ActiveCell.FormulaR1C1 = dtRecvd
                For Each myAttachment In myItem.Attachments
                    If InStr(myAttachment.DisplayName, ".xlsx") Then
                        I = I + 1
                        myAttachment.SaveAs Filename:=FacModPath & "\" & myAttachment.DisplayName
                        Exit For
                    Else
                        MsgBox "No attachment found."
                        Exit For
                    End If
                Next
            End If
        End If
    Next

Else

    MsgBox "No emails found."
    Exit Sub

End If

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Отдельный, но связанный вопрос: если я хочу искать электронные письма, которые находятся в папке архива Outlook или даже в подпапке «Входящие», нужно ли мне форматировать эту строку кода по-другому?

Set olInb = olns.GetDefaultFolder(6)

Answer 1

Конечно, перебирать все элементы в папке - не самая лучшая и правильная идея. Вам нужно использовать методы Restrict или Find / FindNext класса Items, чтобы получить только те предметы, которые соответствуют вашим условиям. Дополнительные сведения об этих методах см. В следующих статьях:

• Как: использовать методы Find и FindNext для извлечения элементов почты Outlook из папки (C#, VB. NET)
• Как: использовать метод Restrict для извлечения элементов почты Outlook из папки

В приведенном выше коде я заметил следующую строку:

Set olMail = olInb.Items.Restrict("[Subject] = ""*Blue Recruit Req Data*""")

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

Sub MoveItems()  
    Dim myNamespace As Outlook.NameSpace  
    Dim myFolder As Outlook.Folder  
    Dim myItems As Outlook.Items  
    Dim myRestrictItems As Outlook.Items  
    Dim myItem As Outlook.MailItem  

    Set myNamespace = Application.GetNamespace("MAPI")  
    Set myFolder = _  
        myNamespace.GetDefaultFolder(olFolderInbox)  
    Set myItems = myFolder.Items  
    Set myRestrictItems = myItems.Restrict("[Subject] = ""*Blue Recruit Req Data*""")  
    For i =  myRestrictItems.Count To 1 Step -1  
        myRestrictItems(i).Move myFolder.Folders("Business")  
    Next  
End Sub

Кроме того, я бы изменил строку фильтра, включив в нее записи, которые могут содержать переданную подстроку:

filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & wordsInSubject & " %'"

Чтобы получить упорядоченные элементы, т.е. начать с недавнего или самые старые, вам необходимо отсортировать коллекцию с помощью методов Sort класса Items:

Items.Sort("[ReceivedTime]")

Наконец, вы также можете найти метод AdvancedSearch класса Application. Ключевые преимущества использования метода AdvancedSearch в Outlook:

• Поиск выполняется в другом потоке. Вам не нужно запускать другой поток вручную, поскольку метод AdvancedSearch запускает его автоматически в фоновом режиме.
• Возможность поиска любых типов элементов: почта, встреча, календарь, заметки и c. в любом месте, т.е. за пределами определенной папки. Методы Restrict и Find / FindNext могут применяться к конкретной коллекции Items (см. Свойство Items класса Folder в Outlook).
• Полная поддержка DASL запросы (для поиска также можно использовать настраиваемые свойства). Подробнее об этом можно прочитать в статье Фильтрация в MSDN. Для повышения производительности поиска можно использовать ключевые слова Instant Search, если Instant Search включен для магазина (см. Свойство IsInstantSearchEnabled класса Store).
• Вы можете остановить процесс поиска на в любой момент, используя метод Stop класса Search.

Узнайте больше о методе AdvancedSearch и найдите программный код в расширенном поиске в Outlook: C#, VB. NET артикул.

Answer 2

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

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

Несколько предложений:

1- Используйте option explicit в верхней части ваших модулей 2- Попробуйте определить ваши переменные как что-то значимое (используйте имена любой может понять) 3- Постарайтесь сделать отступ в коде последовательно (вы можете использовать RubberDuck

Перед вставкой кода:

Используйте раннее связывание , чтобы установить ссылку на библиотеку объектов Outlook и воспользоваться преимуществами intellisense и другими преимуществами

1) Щелкните инструменты | Ссылки

2) Проверьте библиотеку объектов Microsoft Outlook XXX

---

Вот отредактированный код:

Выполните его с помощью клавиши F8 и настройте его под свои нужды

Public Sub CheckEmail_BlueRecruit()

    ' Declare objects
    Dim outlookApp As Outlook.Application
    Dim outlookNamespace As Outlook.Namespace
    Dim outlookFolder As Outlook.MAPIFolder

    ' Declare other variables
    Dim filterKeywords As String
    Dim filter As String

    ' Init objects
    Set outlookApp = New Outlook.Application
    Set outlookNamespace = Outlook.GetNamespace("MAPI")
    Set outlookFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)

    ' Init other variables
    filterKeywords = "financial"
    filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & filterKeywords & " %'"


    ' Loop through folders
    LoopFolders outlookFolder, filter


End Sub

Private Sub LoopFolders(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)

    ' DeclareObjects
    Dim outlookSubFolder As Outlook.MAPIFolder
    Dim outlookMail As Outlook.MailItem

    ProcessFolder outlookFolder, filter

    If outlookFolder.Folders.Count > 0 Then
        For Each outlookSubFolder In outlookFolder.Folders
            LoopFolders outlookSubFolder, filter
        Next
    End If

End Sub

Private Sub ProcessFolder(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)

    Dim outlookItems As Outlook.Items
    Dim outlookMail As Outlook.MailItem

    ' Filter folder
    Set outlookItems = outlookFolder.Items.Restrict(filter)

    If Not outlookItems Is Nothing Then

        For Each outlookMail In outlookItems

            If outlookMail.Attachments.Count <> 0 Then

                Debug.Print outlookMail.Subject

            End If

        Next outlookMail

    End If

End Sub

Сообщите мне, если он работает, и вам нужна дополнительная помощь