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