Excel List to Outlook Email Search

Hello All,

I'm searching for a VBA Code to find a solution to this very unique situation.

my team members search for emails using excel file having order numbers in column A and it has invoice number in Column B.

then search for the email using the subject line containing the order number, which are system generated and come from single system generated email.

once they find the email they edit the email either by replying or forwarding and taking a print out as they need a hard copy with has both invoice number and order number P.S. they don't send the email they only forward or reply to edit the subject / mail body to add the invoice number.

I need someone to help me with the code i have the below code but i fail to do the edit forwarding and printing & loop this cycle.

Sample Table & code below.

Attachment 25541

PublicSub sofWorkWithOutlook()
Dim outlookApp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail AsVariant
Dim myTasks

Dim oMail As MailItem
Dim myItem As Outlook.MailItem

'Set outlookApp = New Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")

Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
Set myItem = Outlook.ActiveInspector.CurrentItem

'
Set olMail = myTasks.Find("[Subject] = ""1806594500""")
'
ForEach olMail In myTasks
'
If(InStr(1, olMail.Body,"1806594500", vbTextCompare)>0)Then
olMail.Display
Dim myinspector As Outlook.Inspector

oMail.Display
myItem.Forward
olMail.PrintOut
ExitFor
EndIf
Next
EndSub

someone please help

Frankly I don't see why you need to create a new message. Why not simply edit the message you have, given that it is system generated? Something like the following should work - note the comments in the code - especially the first one as you'll need to download some code.

Code:

---

Option Explicit

Public Sub sofWorkWithOutlook()
Dim olApp As Object
Dim olNs As Object
Dim olFldr As Object
Dim olMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim strNum As String
Dim xlSheet As Worksheet
Dim LastRow As Long, lngRow As Long


    'Use the code from the link below to start Outlook properly from Excel
    'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
    Set olApp = outlookApp()


    Set olNs = olApp.GetNamespace("MAPI")
    Set olFldr = olNs.GetDefaultFolder(6)


    Set xlSheet = ActiveSheet
    With xlSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For lngRow = 2 To LastRow
            strNum = .Cells(LastRow, 1)
            For Each olMail In olFldr.Items
                If TypeName(olMail) = "MailItem" Then
                    If (InStr(1, olMail.Subject, strNum, vbTextCompare) > 0) Then
                        With olMail
                            Set olInsp = .GetInspector
                            Set wdDoc = olInsp.WordEditor    'access the message body for editing
                            Set oRng = wdDoc.Range 'orng is the message body
                            '.subject 'is the message subject. Edit it as required
                            .display
                            'edit oRng as required
                            .Save
                            .PrintOut
                            Exit For
                        End With
                    End If
                End If
                DoEvents
            Next olMail
            DoEvents
        Next lngRow
    End With


    Set olMail = Nothing
    Set olFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

---

Hey GMayor, thank you for the response, i agree editing directly works fine as well.

I do not wish to save the changes on the original email. so i removed the .save code. what i achieve is to run this search in a sequence for eg. first search happens on sales order number in column A2 and when it finds it the email then it edits the subject and adds the invoice number from b2 at the end and then takes a print out. once done, the code runs to search for a3 and when it finds it the email then it edits the subject and adds the invoice number from b3 at the end . i hope i'm able to explain what i am trying to achieve.

Hey Gmayor,

My purpose gets met when i add the subject line as

Code:

---

.Subject = olMail.Subject & " - " & "123" 'is the message subject. Edit it as required

---

however what i wish to achieve is a loop to search a2 and then paste b2 in the subecjt instead of the 123 i've mentioned now
and then search for a3 and then paste b3 in the subject line before printing. i've removed the .save code as i do not wish to make any changes to the original message.

i'm unable to run this in loop, your code only searches for the last row in the column A as seen in the code which is not what i wish to achieve.

thank you.

Hey Gmayor,


I've made a few changes and i'm able to meet my requirements on finding the email and editing the subject without saving the changes to the subject but direct printing, what i'm left with is getting these searches of SO Number in sequence of A2, A3 and corresponding invoice number getting pasted into the subject as B2 , B3... respectively.

Code:

---

Option Explicit


Public Sub Test_sofWorkWithOutlook()
Dim olApp As Object
Dim olNs As Object
Dim olFldr As Object
Dim olMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim strNum As String
Dim strNum1 As String
Dim xlSheet As Worksheet
Dim LastRow As Long, lngRow As Long
Dim Subject As Long
Dim LastRow1 As Long, lngRow1 As Long




    'Set olApp = outlookApp()
    Set olApp = GetObject(, "Outlook.Application")




    Set olNs = olApp.GetNamespace("MAPI")
    Set olFldr = olNs.GetDefaultFolder(6)
   
    Set xlSheet = ActiveSheet
    With xlSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastRow1 = .Cells(.Rows.Count, "B").End(xlUp).Row
       
    For lngRow = 1 To LastRow
        For lngRow1 = 1 To LastRow1
            strNum = .Cells(LastRow, 1)
            strNum1 = .Cells(LastRow1, 1)
            For Each olMail In olFldr.Items
                If TypeName(olMail) = "MailItem" Then
                    If (InStr(1, olMail.Subject, strNum, vbTextCompare) > 0) Then
                        With olMail
                            Set olInsp = .GetInspector
                            Set wdDoc = olInsp.WordEditor    'access the message body for editing
                            Set oRng = wdDoc.Range 'orng is the message body
                            .Subject = olMail.Subject & " " & strNum1
                            '.Display
                            'edit oRng as required
                            '.Save
                            .PrintOut
                            Exit For
                        End With
                    End If
                End If
                DoEvents
            Next olMail
            DoEvents
        Next lngRow1
    Next lngRow
    End With








    Set olMail = Nothing
    Set olFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

---

i'm unable to run this in loop, your code only searches for the last row subject in the column A as seen in the code which is not what i wish to achieve.


thank you.

couldn't edit the earlier reply hence adding a new reply

Quote:

---

Originally Posted by gmayor

Frankly I don't see why you need to create a new message. Why not simply edit the message you have, given that it is system generated? Something like the following should work - note the comments in the code - especially the first one as you'll need to download some code.

---

Hi Gmayor, could you please help me with this.

There was a typo in my original, which is why it only processed the last row and why your subsequent changes, echoed the same issue. The following should address your comments.

Code:

---

Public Sub Test_sofWorkWithOutlook()
Dim olApp As Object
Dim olNs As Object
Dim olFldr As Object
Dim olMail As Object
Dim strNum As String
Dim strNum1 As String
Dim xlSheet As Worksheet
Dim LastRow As Long, lngRow As Long
Dim Subject As Long


    'Set olApp = outlookApp()
    Set olApp = GetObject(, "Outlook.Application")


    Set olNs = olApp.GetNamespace("MAPI")
    Set olFldr = olNs.GetDefaultFolder(6)


    Set xlSheet = ActiveSheet
    With xlSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For lngRow = 1 To LastRow
            strNum = .Cells(lngRow, 1)
            strNum1 = .Cells(lngRow, 2)
            For Each olMail In olFldr.Items
                If TypeName(olMail) = "MailItem" Then
                    If (InStr(1, olMail.Subject, strNum, vbTextCompare) > 0) Then
                        With olMail
                            .Subject = olMail.Subject & " " & strNum1
                            .PrintOut
                            Exit For
                        End With
                    End If
                End If
                DoEvents
            Next olMail
            DoEvents
        Next lngRow
    End With


    Set olMail = Nothing
    Set olFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

---

Quote:

---

Originally Posted by gmayor

There was a typo in my original, which is why it only processed the last row and why your subsequent changes, echoed the same issue. The following should address your comments.

---

Oh My GOD! you wouldn't believe how big of a relief this is for me. could you explain where was the typo so that i'm able to learn the VBA further more.

Thanks a Million ! you Rock Sir.

Code:

---

strNum = .Cells(LastRow, 1)

---

Should be

Code:

---

strNum = .Cells(lngRow, 1)

---

Quote:

---

Originally Posted by gmayor

Code:

---

strNum = .Cells(LastRow, 1)

---

Should be

Code:

---

strNum = .Cells(lngRow, 1)

---

---

Hi @gmayor,

Thank you so much for your support on this code so far. i wish to understand how do i save the searched email item as PDF rather than printing.

i searched over the web, however didn't find relevant solution or maybe i didn't understand.

I'm hoping there would be a simpler way to save the mail item as PDF.

Regards,
Pawan Tejani.

Hey, i was able to resolve the above issue, by adding the below line

Code:

---

.SaveAs Environ("HOMEPATH") & "\My Documents\" & olMail.Subject & ".html", olHTML

---

now another request is to search in all the folders and not only the inbox folders. as few users move emails to sub folders or save to archive or PSTs.