PDA

View Full Version : VBA to Search both Email subject and/or Email Body in Outlook



patcell67
05-25-2016, 11:52 AM
Let me explain my dilemma.. I have created (through frankensteining some code) a macro that searches an Outlook Inbox for a specified email subject then saves the email itself (or the pdf attachment) either as a .msg file or a .pdf file, depending on user input. The code works if you only want to search the Subject of an email but the issue i am running into is if a customer does not put their PO number in the subject, but in the body of the email. Basically, I need to fix my VBA script to search first for the Subject of an Email and if the string specified is not within the subject, to then search the body of the email. Here is the code I currently have (which is only searches Email subject):


Sub CommandButton7_Click()

Dim olApp As Outlook.Application
Dim olFldr As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olAtt As Outlook.Attachment
Dim sPath As String
Dim sFile As String
Dim sName As String
Dim sName2 As String
Dim olNS As Namespace
Dim SenderName1 As String
Dim MailSub As String


AppActivate "Session A - [27 x 132]"


'Use this to pause before pasting, this is .1 seconds
'LenTime = 0.1
Dim Start
Call Pause(0.1)


SendKeys "^a" & "^c"




Sheets("Sheet1").Range("A1").PasteSpecial "Text"



Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False

If Sheets("Orders").Range("F5").Value <> "" Then
SenderName1 = Sheets("Orders").Range("F5").Value
End If

If Sheets("Orders").Range("F5").Value = "" Then
SenderName1 = Application.InputBox("Enter Sender Name")
End If

If Sheets("Orders").Range("F7").Value = "" Then
MailSub = Application.InputBox("Paste PO Email Subject")
End If

If Sheets("Orders").Range("F7").Value <> "" Then
MailSub = Sheets("Orders").Range("F7").Value
End If

sPath = "T:\Sales\PDFs\Sales Orders\2016 Orders\"

sName = Sheets("Orders").Range("Z16").Value & " [" & Sheets("Orders").Range("F2").Value & "]"
sName2 = Sheets("Orders").Range("Z16").Value & " [" & Sheets("Orders").Range("F2").Value & "]" & ".msg"

Set olApp = New Outlook.Application
Set olNS = GetNamespace("MAPI")
Set olFldr = olNS.Folders("Sales").Folders("May 2016")
strPath = "T:\Sales\PDFs\Sales Orders\2016 Orders\"

intMessage = MsgBox("Is the PO in an Attachment?", vbYesNo)



For Each olMail In olFldr.Items
For Each olAtt In olMail.Attachments
If InStr(1, olMail.SenderName, SenderName1) And InStr(1, olMail.Subject, MailSub) > 0 And intMessage = vbYes Then
sFile = sPath & sName & ".pdf"
olAtt.SaveAsFile sFile
ActiveWorkbook.FollowHyperlink sFile

Call Pause(0.9)
SendKeys "%{f4}"
Sheets("Sheet1").Range("A1:A24").Value = ""
Exit Sub
End If
Next

If InStr(1, olMail.SenderName, SenderName1) And InStr(1, olMail.Subject, MailSub) > 0 And intMessage = vbNo Then


sName = Sheets("Orders").Range("Z16").Value & ".msg"


olMail.SaveAs strPath & sName2, olMsg

Sheets("Sheet1").Range("A1:A24").Value = ""

Exit Sub
End If





Set olFldr = Nothing
Set olApp = Nothing

Next

Application.ScreenUpdating = True

End Sub

I tried to modify the If InStr line to this:

If InStr(1, olMail.SenderName, SenderName1) And (InStr(1, olMail.Subject, MailSub) Or InStr(1, olMail.Body, MailSub)) > 0 And intMessage = vbYes Then

But that didn't work. Any ideas from how i can modify this code to search for email Subject first, then search the Body?

Thanks in advance!

patcell67
05-25-2016, 03:39 PM
no ideas? maybe i'm explaining wrong.. any questions, please let me know!

snb
05-26-2016, 01:53 AM
have a look over here:

http://www.snb-vba.eu/VBA_Outlook_external_en.html#L157

patcell67
05-26-2016, 08:04 AM
have a look over here:


This doesn't quite work for my purposes. I was looking for something using the InStr command to search for the email subject string, and if not present - to then search the Body of the emails in the specified folder. I tried to use the Find command in that link but i can't get it to work with my code. I tried using this code:
For Each olMail In olFldr.Items For Each olAtt In olMail.Attachments
If InStr(1, olMail.Subject, MailSub) = 0 Then
GoTo NextLine
End If
If InStr(1, olMail.SenderName, SenderName1) And InStr(1, olMail.Subject, MailSub) > 0 And intMessage = vbYes Then
sFile = sPath & sName & ".pdf"
olAtt.SaveAsFile sFile
ActiveWorkbook.FollowHyperlink sFile

Call Pause(0.9)
SendKeys "%{f4}"
Sheets("Sheet1").Range("A1:A24").Value = ""
Exit Sub
End If
Next
Next


NextLine:
For Each olMail In olFldr.Items
For Each olAtt In olMail.Attachments
If InStr(1, olMail.SenderName, SenderName1) And InStr(1, olMail.Body, MailSub) > 0 And intMessage = vbYes Then
sFile = sPath & sName & ".pdf"
olAtt.SaveAsFile sFile
ActiveWorkbook.FollowHyperlink sFile

Call Pause(0.9)
SendKeys "%{f4}"
Sheets("Sheet1").Range("A1:A24").Value = ""
Exit Sub
End If But this code is saving a pdf that seems to be corrupt and cannot be opened. I am guessing this is due to the fact it is not finding the correct email through the body.