Find and Open an email in Outlook

[Poundland]

Guys,

I have the below code, which works, it finds a specific email, and saves the attachment on the email to another folder in explorer.

The problem I have is that each day the email name will change in respect that the Date and Time will change.

How can I modify the line of code that has the name of the subject name of the email so that it looks for key words rather than the entire and full subject name?

Option Explicit
Sub SaveFundAttachments()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olInBox As Outlook.MAPIFolder
    Dim olMoveToFolder As Outlook.MAPIFolder
    Dim olItems As Outlook.Items
    Dim olAtt As Outlook.Attachment
    Dim strSaveToFolder As String
    Dim strPathAndFilename As String
    Dim Ans As Long
    Dim i As Long
    
    strSaveToFolder = "I:\H904 Supply Chain\Scott Atkinson\Dashboard\"
    
    If Right(strSaveToFolder, 1) <> "\" Then strSaveToFolder = strSaveToFolder & "\"
    
    Set olApp = CreateObject("Outlook.Application")
    
    Set olNS = olApp.GetNamespace("MAPI")
    Set olInBox = olNS.GetDefaultFolder(olFolderInbox)
    
    ' ***** How can I amend the below line to search for part of the Subject name and not all of it *****
    Set olItems = olInBox.Items.Restrict("[Subject] = 'Availability Measurement by SKU was executed at 23/01/2016 10:31:56'")
    
    
    For i = olItems.Count To 1 Step -1
        If olItems(i).Attachments.Count > 0 Then
            For Each olAtt In olItems(i).Attachments
                strPathAndFilename = strSaveToFolder & olAtt.Filename
                If Len(Dir(strPathAndFilename, vbNormal)) = 0 Then
                    olAtt.SaveAsFile strPathAndFilename
                    olItems(i).Save
                Else
                    Ans = MsgBox(olAtt.Filename & " already exists.  Overwrite file?", vbQuestion + vbYesNo)
                    If Ans = vbYes Then
                        olAtt.SaveAsFile strPathAndFilename
                        olItems(i).Save
                    End If
                End If
            Next olAtt
           
        End If
    Next i
    
    Set olApp = Nothing
    Set olNS = Nothing
    Set olInBox = Nothing
    Set olMoveToFolder = Nothing
    Set olItems = Nothing
    Set olAtt = Nothing
    
End Sub

[mancubus]

?

Sub vbax_54989_FindEmailsWithSpecificSubject()
    
    Dim olMail As Object, olAtt As Object
    Dim strSaveToFolder As String, strPathAndFilename As String
    
    strSaveToFolder = "I:\H904 Supply Chain\Scott Atkinson\Dashboard\"

    With CreateObject("Outlook.Application")
        For Each olMail In .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
            If InStr(olMail.Subject, "Availability Measurement by SKU was executed") > 0 Then
                If olMail.Attachments.Count > 0 Then
                    For Each olAtt In olMail.Attachments
                        strPathAndFilename = strSaveToFolder & olAtt.Filename
                        If Len(Dir(strPathAndFilename, vbNormal)) = 0 Then
                            olAtt.SaveAsFile strPathAndFilename
                            olMail.Save
                        Else
                            If MsgBox(olAtt.Filename & " already exists.  Overwrite file?", vbQuestion + vbYesNo) = vbYes Then
                                olAtt.SaveAsFile strPathAndFilename
                                olMail.Save
                            End If
                        End If
                    Next olAtt
                End If
            End If
        Next
    End With

End Sub

[Poundland]

Thank you. This code works perfectly.

[mancubus]

you are welcome. thanks for the feedback.

[snb]

Outlook has some builtin find/filter tools.

Sub M_snb()
   On Error Resume Next
  c00 ="Availability Measurement by SKU was executed"

  With CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(6).Items
     for each at in .Find("[Subject]='" & c00 & "'").attachments
      at.saveasfile "I:\H904 Supply Chain\Scott Atkinson\Dashboard\" & at.filename
    next
  End With
End Sub

read more:

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