Search for email using cell value and attach referenced file

[scotsrule08]

Here’s a doozy!

I have a spreadsheet with reference numbers and the path to a spreadsheet for each reference number.

I would like to search through Outlook for an email with the subject line that includes the reference number, then with that email reply with the specific referenced spreadsheet. Then loop through all of the cells.

The reference numbers are in column A and the corresponding file path is in column B.

Any help is appreciated Ladies & Gents!

 

[Kamolga]

Hi,

You would need to go in vba/tools/references... and tick Microsoft Outlook 16.0 (or any version) object library to use outlook from Excel. Keep in mind that this step is required again if you change computer.

This is untested but that is the structure I would use:

Sub LoopEmails()


Dim objNS As Outlook.Namespace: Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Dim Item As Object
Dim ref As Range
Dim sht As Worksheet
Set sht = ActiveSheet
Dim LastRow As Long
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Dim olReply As MailItem


For Each Item In olFolder.Items
    If TypeOf Item Is Outlook.MailItem Then
        Dim oMail As Outlook.MailItem: Set oMail = Item
        For Each ref In Range("A1:A" & LastRow)
            If InStr(1, oMail.Subject, ref.Value) <> 0 Then
                Set olReply = oMail.ReplyAll
                olReply.HTMLBody = "Hello, Here is a path: " & ref.Offset(0, 1).Value & vbCrLf & oMail.HTMLBody
                olReply.Display '.send to send without display
            End If
        Next ref
    End If
Next Item


End Sub

 

[Kamolga]

Hi,

I tested it and basically had an issue with empty cell (it replies to all mails then), so I would rather use this one

Sub LoopEmails()


Dim objNS As Outlook.Namespace: Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Dim Item As Object
Dim ref As Range
Dim sht As Worksheet
Set sht = ActiveSheet
Dim LastRow As Long
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Dim olReply As MailItem


For Each Item In olFolder.Items
    If TypeOf Item Is Outlook.MailItem Then
        Dim oMail As Outlook.MailItem: Set oMail = Item
        For Each ref In Range("A1:A" & LastRow)
           [COLOR=#006400]'Check reference cell is not empty and included in mail subject[/COLOR]
           [COLOR=#0000ff] If (ref.value<>"" and InStr(1, oMail.Subject, ref.Value) <> 0)[/COLOR] Then
                Set olReply = oMail.ReplyAll
                olReply.HTMLBody = "Hello, Here is a path: " & ref.Offset(0, 1).Value & vbCrLf & oMail.HTMLBody
                olReply.Display '.send to send without display
            End If
        Next ref
    End If
Next Item


End Sub