VBA to Search both Email subject and/or Email Body in Outlook

[patcell67]

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]

no ideas? maybe i'm explaining wrong.. any questions, please let me know!

[snb]

have a look over here:

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

[patcell67]

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.