Vba Outlook在收件箱中扫描主题中的特定字符串

我正在做一个项目，我需要outlook中的一个宏，该宏将在收件箱中扫描主题字段中包含“参考号”的电子邮件。如果未检测到电子邮件，则系统可以从excel电子表格转到下一个参考

如果检测到电子邮件，则会将其提取为“MSG”文件，并将实际电子邮件移动到子文件夹中。到目前为止，我有一个将电子邮件提取为“MSG”文件的代码，但我无法让它识别主题字段中的特定字符串（参考号）。我从这个网站得到了下面的EXCEL宏代码

Sub Work_with_Outlook()

Set outlookApp = CreateObject("Outlook.Application")

Dim olNs As Outlook.NameSpace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim sir() As String

Set outlookApp = New Outlook.Application
Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items

Set olMail = myTasks.Find("[Subject] = ""Macro""")
If Not (olMail Is Nothing) Then
    olMail.Display
End If

End Sub                           

请尝试以下代码：

Sub SaveAttachments()

    Dim myOlapp As Outlook.Application
    Dim myNameSpace As Outlook.Namespace
    Dim myFolder, destFolder As Outlook.MAPIFolder
    Dim i, lr As Long

    'last used row in excel
    lr = Cells(Rows.Count, "A").End(xlUp).Row

    Set myOlapp = GetObject(, "Outlook.application")
    Set myNameSpace = myOlapp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set destFolder = myFolder.Folders("provide subFolderName here")
    Set mytask = myFolder.Items

    'Download and move attachment if found
    For i = 1 To lr

        'The below line of code will not work if you are using wild card or partial string
        Set ref = mytask.Find("[Subject] =" & Range("a" & i).Value)
        If Not (ref Is Nothing) Then
            ref.Attachments.Item(1).SaveAsFile "C:\" & Range("a" & i).Value & ".msg"
            ref.Move destFolder
        End If
        Set ref = Nothing

        'The workaround code goes as below
        For Each myItem In mytask
            If myItem.Class = olMail Then
                If InStr(1, myItem.Subject, Range("a" & i).Value) > 0 Then
                    myItem.Attachments.Item(1).SaveAsFile "C:\" & Range("a" & i).Value & ".msg"
                    myItem.Move destFolder
                End If
            End If
        Next myItem

    Next i

    Set myOlapp = Nothing
    Set myNameSpace = Nothing
    Set myFolder = Nothing
    Set destFolder = Nothing
    Set mytask = Nothing

End Sub

注意：假设参考号在“A”列中，请尝试以下代码：

Sub SaveAttachments()

    Dim myOlapp As Outlook.Application
    Dim myNameSpace As Outlook.Namespace
    Dim myFolder, destFolder As Outlook.MAPIFolder
    Dim i, lr As Long

    'last used row in excel
    lr = Cells(Rows.Count, "A").End(xlUp).Row

    Set myOlapp = GetObject(, "Outlook.application")
    Set myNameSpace = myOlapp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set destFolder = myFolder.Folders("provide subFolderName here")
    Set mytask = myFolder.Items

    'Download and move attachment if found
    For i = 1 To lr

        'The below line of code will not work if you are using wild card or partial string
        Set ref = mytask.Find("[Subject] =" & Range("a" & i).Value)
        If Not (ref Is Nothing) Then
            ref.Attachments.Item(1).SaveAsFile "C:\" & Range("a" & i).Value & ".msg"
            ref.Move destFolder
        End If
        Set ref = Nothing

        'The workaround code goes as below
        For Each myItem In mytask
            If myItem.Class = olMail Then
                If InStr(1, myItem.Subject, Range("a" & i).Value) > 0 Then
                    myItem.Attachments.Item(1).SaveAsFile "C:\" & Range("a" & i).Value & ".msg"
                    myItem.Move destFolder
                End If
            End If
        Next myItem

    Next i

    Set myOlapp = Nothing
    Set myNameSpace = Nothing
    Set myFolder = Nothing
    Set destFolder = Nothing
    Set mytask = Nothing

End Sub

注：假设参考号在“A”列中