PDA

View Full Version : [SOLVED] Find and Open an email in Outlook



Poundland
01-28-2016, 04:17 AM
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
01-28-2016, 05:06 AM
?


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
01-28-2016, 05:24 AM
Thank you. This code works perfectly.

mancubus
01-28-2016, 08:24 AM
you are welcome. thanks for the feedback.

snb
01-28-2016, 09:20 AM
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