Excel List to Outlook Email Search

[ppawan]

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.

25541

Public Sub sofWorkWithOutlook()
Dim outlookApp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
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""")
'
For Each 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
Exit For
End If
Next
End Sub

[ppawan]

someone please help

[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.



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

[ppawan]

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.

[ppawan]

Hey Gmayor,

My purpose gets met when i add the subject line as

.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.

[ppawan]

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.

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

[ppawan]

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.

[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.


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

[ppawan]

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.

[gmayor]

strNum = .Cells(LastRow, 1)
Should be
strNum = .Cells(lngRow, 1)

[ppawan]

strNum = .Cells(LastRow, 1)
Should be
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.

[ppawan]

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

.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.