I have code that downloads the attachment (xlsb) from the last email in my inbox.
I have two problems:
1 - I need to change this so it looks for the first email (latest) first.
2 - It should only look for emails with a subject containing the words: DOCUMENT_APP (the name varies but it always has document_app in it, so it needs to use a wildcard)
This is the code I have which looks for the oldest email and saves the xlsb attachment file (disregarding the subject):
Sub DownloadAttachmentFirstEmail()
Application.StatusBar = False
Application.StatusBar = "Downloading email"
Application.DisplayAlerts = False
Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object, oOlAtch As Object
'~~> New File Name for the attachment
Dim NewFileName As String
NewFileName = AttachmentPath & Format(Date, "DD-MM-YYYY") & "-"
'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
For Each oOlItm In oOlInb.Items
'~~> Check if the email actually has an attachment
If oOlItm.Attachments.Count <> 0 Then
For Each oOlAtch In oOlItm.Attachments
If Right(oOlAtch.Filename, 4) = "xlsb" Then
oOlAtch.SaveAsFile NewFileName & oOlAtch.Filename
MsgBox "SAVED"
Exit Sub
End If
Next
Else
End If
Next
' DO SOMETHING
End Sub
For problem no. 2, I tried changing:
For Each oOlItm In oOlInb.Items
to:
For Each oOlItm In oOlInb.Items.Restrict("[Subject] = ""*DOCUMENT_APP*""")
It gives no error, it just exits sub.
niton gave a usefull link, I was able to get it done by using:
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%sketch%'"
Related
I've written some code that scans my default Outlook inbox for emails received today with a specific subject.
I then download the attachment for Outlook items that meet my criteria. I am having trouble designating the Restrict method to pull back items received today.
Here is what I have:
Sub DownloadAttachmentFirstUnreadEmail()
Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object, oOlAtch As Object
Dim sFilter As String
Dim NewFileName As String
NewFileName = "C:\Temp\" & "CHG_Daily_Extract_" & Format(Date, "MM-DD-YYYY") & ".csv"
'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'Declare email item restriction
sFilter = "[ReceivedTime] = '" & Format(Date, "DDDDD HH:NN") & "'"
'Catch
If oOlInb.Items.Restrict(sFilter).Count > 0 Then
'~~> Loop thru today's emails
For Each oOlItm In oOlInb.Items.Restrict(sFilter)
'~> Check if the email subject matches
If oOlItm = "ASG CDAS Daily CHG Report" Then
'~~> Download the attachment
For Each oOlAtch In oOlItm.Attachments
oOlAtch.SaveAsFile NewFileName
Exit For
Next
End If
Exit For
Next
'Display if no emails today
Else: MsgBox "No items"
End If
End Sub
When I run the code, I consistently receive my catch message of "No items".
Please let me know if I am using the Restrict method incorrectly. Thank you so much for the help.
How about the following-
Filter = "#SQL=" & "%today(" & Chr(34) & ("urn:schemas:httpmail:datereceived") & _
Chr(34) & ")%
Or with Attachment
Filter = "#SQL=" & "%today(" & Chr(34) & ("urn:schemas:httpmail:datereceived") & _
Chr(34) & ")% AND " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1"
Example
Option Explicit
Private Sub Examples()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Msg As String
Dim i As Long
Dim Filter As String
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Filter = "#SQL=" & "%today(" & Chr(34) & ("urn:schemas:httpmail:datereceived") & _
Chr(34) & ")%"
Set Items = Inbox.Items.Restrict(Filter)
Msg = Items.Count & " Items in " & Inbox.Name
If MsgBox(Msg, vbYesNo) = vbYes Then
For i = Items.Count To 1 Step -1
Debug.Print Items(i) 'Immediate Window
Next
End If
End Sub
Filtering Items Using a Date-time Comparison MSDN
Outlook Date-time Macros
The date macros listed below return filter strings that compare the value of a given date-time property with a specified date in UTC; SchemaName is any valid date-time property referenced by namespace.
Note Outlook date-time macros can be used only in DASL queries.
Macro Syntax Description
today %today(" SchemaName")% Restricts for items with SchemaName
property value equal to today
More Examples Here
I've got this block of code to go through all the emails in my "Today" folder in Outlook, then save all the emails (.msg) to a folder named as the sender name.
Sometimes the files are saving with the file type "file".
How do I fix this to make sure the emails are saved as .msg files?
Sub SaveAttachments()
'https://www.fontstuff.com/outlook/oltut01.htm
'Declare Variables
Dim ns As NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim Savefolder As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox).Folders("Today")
i = 0
'Stop script if there are no emails
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, "Nothing Found"
Exit Sub
End If
'Display the number of emails
MsgBox Inbox.Items.Count, vbInformation, _
"Number of Emails?"
'Go through each email
For Each Item In Inbox.Items
'Create a path for the save folder
Savefolder = "C:\Users\work\Desktop\22_11_18\Test\" & Item.SenderName
'If the email has attachments, then create a folder
If Item.Attachments.Count > 0 Then
MkDir Savefolder
'If the folder already exists, skip to the next statement
On Error Resume Next
'Save the email as a .msg file
Item.SaveAs Savefolder & "\" & Item.Subject & ".msg"
End If
Next Item
End Sub
You can use subject if the characters in the subject are all valid.
Option Explicit
Private Sub SaveMail_ContainingAttachments_ValidSubject()
'Declare Variables
Dim ns As Namespace
Dim targetFolder As Folder
Dim itm As Object
Dim atmt As Attachment
Dim strSaveFolder As String
Dim validSubject As String
Set ns = GetNamespace("MAPI")
Set targetFolder = ns.GetDefaultFolder(olFolderInbox)
Set targetFolder = targetFolder.Folders("Today")
'Stop script if there are no emails
If targetFolder.Items.count = 0 Then
MsgBox "There are no messages in " & targetFolder & ".", vbInformation, "Nothing Found"
Exit Sub
End If
'Display the number of emails
MsgBox targetFolder.Items.count, vbInformation, "Number of Emails?"
'Go through each email
For Each itm In targetFolder.Items
'If the email has attachments, then create a folder
If itm.Attachments.count > 0 Then
'Create a path for the save folder
strSaveFolder = "C:\Users\work\Desktop\22_11_18\Test\" & itm.senderName
' Bypass error if the folder already exists
On Error Resume Next
MkDir strSaveFolder
' Discontinue error bypass as soon as the purpose is served
' Let unknown errors generate then fix them
On Error GoTo 0
' Replace or remove invalid characters
' Possible options "_" or " " or "" ....
validSubject = ReplaceIllegalChar(itm.subject, "_")
If validSubject <> itm.subject Then
Debug.Print itm.subject
Debug.Print validSubject
End If
'Save the email as a .msg file
itm.SaveAs strSaveFolder & "\" & validSubject & ".msg"
End If
Next itm
End Sub
Private Function ReplaceIllegalChar(strInput, strReplace)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\#\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
' Replace with another string
ReplaceIllegalChar = RegX.Replace(strInput, strReplace)
ExitFunction:
Set RegX = Nothing
End Function
I'm trying to write a code to download weekly assignments (attachments) and save it to a folder.
I got a code which goes through every item and downloads all the attachments but it goes from latest to earliest date. I need the latest one as the earlier attachments will overwrite the later ones.
I added a restrict method to look for items that are sent today but it still goes through the whole inbox.
Sub downloadAttachment()
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim myItems As Items
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim sFilter As String
'Setting variable for inbox.
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
**sFilter = "[ReceivedTime]>=""&Date()12:00am&"""
Set myItems = Inbox.Items.Restrict(sFilter)**
i = 0
'Error handling.
On Error GoTo downloadattachment_err
'if no attachments, msgbox displays.
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
'Goes through each item in inbox for attachments.
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "txt" Then
FileName = "C:\losscontroldbases\pendingworkdownload\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
'If attachments found, the displays message.
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\losscontroldbases\pendingworkdownload." _
& vbCrLf & "Have a nice day!"
Else
MsgBox "I didn't find any attached files in your mail."
End If
'Clearing memory.
downloadattachment_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
'Error handling code.
downloadattachment_err:
MsgBox " An unexpected error has occured."
End Sub
Your code references "date" string as a literal value. Use something like
Filter = "[ReceivedTime]>= '" & CStr(Date()) & " 12:00am' "
I am working on a project using excel-vba and outlook.
I am working in an excel workbook. I need to be able to run a macro in order to:
Check if there are unread emails,
Dim oOutlook As Object
Dim oOlns As Object
Dim oOlInb As Object
Const olFolderInbox = 6
'~~> Get Outlook instance
Set oOutlook = GetObject(, "Outlook.application")
Set oOlns = oOutlook.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'~~> Check if there are any actual unread emails
If oOlInb.Items.Restrict("[UnRead] = True").Count = 0 Then
MsgBox "NO Unread Email In Inbox"
Else
MsgBox "Unread Email available In Inbox"
Exit Sub
If there are unread emails ,
I need to check if there are attachments in these unread emails.
If there are attachments,
i need to check if these attachments have an attachment name which contains "Production Plan" as part of the name.
This is because this attachment is sent to me regularly.
The attachment name will be in this manner
Production Plan (day - month - year).xls
If there is such an attachment then a MsgBox should be displayed in excel saying
Msg Box "Such attachments are available"
At this point in time i know how to do part 1 and 4.
I want to know: how to do part 2 and 3?
Please guide me on how this can be done.
update: I have made a small addition, which does not work. This is in order to display a msg, if there are attachments detected, but they are not of the form "Production Plan".
Else
If Not att.Filename Like "Production Plan*.xls" Then
MsgBox "no production plan attachment"
Exit Sub
End If
I don't have Outlook, so untested:
EDIT - to list all attachments
Dim oOutlook As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim unRead, m As Object, att As Object
Dim some As String, other As String
Const olFolderInbox = 6
'~~> Get Outlook instance
Set oOutlook = GetObject(, "Outlook.application")
Set oOlns = oOutlook.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'~~> Check if there are any actual unread emails
Set unRead = oOlInb.Items.Restrict("[UnRead] = True")
If unRead.Count = 0 Then
MsgBox "NO Unread Email In Inbox"
Else
some = ""
other = ""
For Each m In unRead
If m.Attachments.Count > 0 Then
For Each att In m.Attachments
If att.Filename Like "Production Plan*.xls" Then
some = some & vbLf & " - " & att.Filename
Else
other = other & vbLf & " - " & att.Filename
End If
Next att
End If
Next m
If some <> "" Or other <> "" Then
MsgBox "Production Plans:" & vbLf & _
IIf(some <> "", some, "{none}") & _
vbLf & vbLf & "Other files:" & vbLf & _
IIf(other <> "", other, "{none}"), _
vbExclamation, "Unread mails with attachments!"
End If
End If
You may find this mammoth answer from Siddharth Rout useful: Download attachment from Outlook and Open in Excel
I've been trying to find a script that saves attachments to a folder on our network from Outlook. I've finally got something working but it looks like it doesn't work on my 2nd system which happens to be Outlook 2010. I can't say for sure if it's because of this difference.
Code is:
Sub SaveAllAttachments(objItem As MailItem)
Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
strLocation = "C:\test\"
On Error GoTo ExitSub
If objItem.Class = olMail Then
Set objAttachments = objItem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
GoTo 100
End If
For dblLoop = 1 To dblCount
strID = " from " & Format(Date, "mm-dd-yy") 'Append the Date
'strID = strID & " at " & Format(Time, "hh`mm AMPM") 'Append the Time
' These lines are going to retrieve the name of the
' attachment, attach the strID to it to insure it is
' a unique name, and then insure that the file
' extension is appended to the end of the file name.
strName = objAttachments.Item(dblLoop).Filename 'Get attachment name
strExt = Right$(strName, 4) 'Store file Extension
strName = Left$(strName, Len(strName) - 4) 'Remove file Extension
strName = strName & strID & strExt 'Reattach Extension
' Tell the script where to save it and
' what to call it
strName1 = strLocation & "PDF\" & strName 'Put it all together
strName2 = strLocation & "JPG\" & strName 'Put it all together
' Save the attachment as a file.
objAttachments.Item(dblLoop).SaveAsFile strName1
objAttachments.Item(dblLoop).SaveAsFile strName2
Next dblLoop
objItem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub
It doesn't matter what Outlook version you are using at the moment. The code should work correcly.
Possible reasons why it doesn't work:
I'd suggest choosing another location for saving files. The C: drive requires admin privileges on latest OS.
The rule is not triggered.
An error in the script. Try to call the script manually from other VBA sub and see what happens under the hood. Do you get any errors in the code?