Outlook scan through the Inbox for a specific string in the subject

Question

I'm working on a project were I need a macro in outlook that will scan through the inbox for an e-mail with a "reference number" contained with-in the subject field. If no e-mail was detected, the system can then move on to the next reference from an excel spreadsheet.

If an e-mail was detected, it gets extracted as an "MSG" file and the actual e-mail moved into a subfolder. So far I have a code for extracting the e-mails as "MSG" files but I cant get it to identify the specific string (reference No) in the subject field. I got the below EXCEL Macro code so far from this site.

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

Anoop Kumar Anoop Kumar · Accepted Answer · 2016-12-05T14:29:03

Try below code:

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

Note: Assuming reference number is in "A" Column

Outlook scan through the Inbox for a specific string in the subject

1 Answers