Execute batch script once for multiple emails - vba

I have multiple emails coming in (Each day I get 3 emails for Orders for 3 Categories). The emails subject are in the format:
"ORDERS EXTRACT - [Category] - [Date]".
Where [Category] can be Category 1, Category 2 or Category 3. [Date] is the date the email was sent in the format DD/MM/YYYY.
I have a rule setup to search for 'Orders' then call the below code.
I want to run Complete.bat after all the email attachments have been saved and I only want to call it once.
I've tried to do this by creating another sub called saveAttachtoDisk_CATEGORY1(itm) that only gets called when it finds "Category 1" in the subject. It then saves the attachment but also searches for a category 1 in the subject AND also searches for yesterday date.
I want a better solution that is not date dependent. A global variable could work where I set the variable to be 1 then run Complete.bat is sent and then in future if variable = 1 then don't run Complete.bat. Not sure where to put this variable (Global variable?) As both the sub modules seem the wrong place to put this and reference it.
Both these two modules are saved under the 'Modules' section of Microsoft Outlook VBA.
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim SaveFolder As String
SaveFolder = "D:\Orders\"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile SaveFolder & "\" & objAtt.DisplayName
objAtt.Delete
Next
itm.Save
End Sub
Other module:
Public Sub saveAttachtoDisk_CATEGORY1(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim SaveFolder As String
SaveFolder = "D:\Orders\"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile SaveFolder & "\" & objAtt.DisplayName
objAtt.Delete
Next
itm.Save
If InStr(1, itm.Subject, "ORDERS EXTRACT - Category 1 -" & Format(Date, "dd/mm/yyyy")) Then
Shell "D:\Orders\Complete.bat"
End If
End Sub

Assumptions
OP will receive exactly three emails per day (though that is
customizable in the code)
The subjects will always begin with "ORDERS EXTRACT -" and no other
emails will begin with that code
OP would like to run Complete.bat once per day upon receipt of the
third ORDERS EXTRACT email.
OP aready has a rule set up to run SaveAttachtoDisk upon receipt of
an ORDERS EXTRACT email. This rule can be changed to run
CategorySaveAndComplete
OP is using Outlook 2013 or later
Proposed Solution
The below code will save the attachments for each Orders Extract email and then check to see if all three have been received. I elected not to use .Find and .FindNext as those methods cannot use wildcards and would therefore require hardcoding the category names. I also elected not to use .Restrict as there are only three items for which we are searching.
That said, solutions with .Find and .Restrict would be valid as well and would work better than the below under certain conditions, such as a user with many items consistently in their Inbox.
Please note that the expected count of Orders Extract emails, subject string to match against, and previous dates to check can all be set via constants. I implemented the previous date check in case OP wanted to check each prior day as well.
Option Explicit
Public Const C_ExpectedOrderCount As Integer = 3 'Set number of expected emails for categories
Public Const C_SubjectFormat As String = "ORDERS EXTRACT - *"
Public Const C_PrevDatesToCheck As Integer = 0 'If the Outlook app may not be open every day, set this to the number of prior days the script should also check.
Public Sub CategorySaveAndComplete(itm As Outlook.MailItem)
'Do not take any action if this is not an ORDERS EXTRACT email.
If itm.Subject Like C_SubjectFormat Then
Dim objAtt As Outlook.Attachment
Dim SaveFolder As String
SaveFolder = "D:\Orders\"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile SaveFolder & "\" & objAtt.DisplayName
objAtt.Delete
Next
itm.Save
'Check all emails in Inbox for ORDERS EXTRACT - * - DATE
Dim Item As Object
Dim objNS As Outlook.NameSpace
Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Dim iLoop As Integer
Dim iCount As Integer
Dim DateCheck As Date
For iLoop = 0 To C_PrevDatesToCheck
'Reset DateCheck and iCount if we are looping through days
DateCheck = DateSerial(Year(Date), Month(Date), Day(Date)) - iLoop
iCount = 0
'Loop through mail items
For Each Item In olFolder.Items
If Item.Class = 43 Then
'This is an email. Check if it matches our criteria.
If Item.Subject Like C_SubjectFormat And CDate(CLng(Item.ReceivedTime)) = DateCheck Then iCount = iCount + 1
End If
Next
'If we have met the expected targets, then run the batch file.
If iCount = C_ExpectedOrderCount Then
'We have exactly the expected number of items. Run the batch file.
Shell "D:\Orders\Complete.bat"
ElseIf iCount > C_ExpectedOrderCount Then
'More items than expected. Check if user is OK with running batch file; if so, run it now.
If MsgBox("More order extracts than expected were received. Expected " & _
C_ExpectedOrderCount & "; received " & iCount & " for " & Format(DateCheck, "mmm d, yy") & _
". Would you like to run the Complete.bat file now?", vbYesNo) = vbYes Then Shell "D:\Orders\Complete.bat"
End If
Next iLoop
End If
End Sub

Related

430 Error on Date - itm.ReceivedTime in a subfolder

I get a 430 error running code on a subfolder of a shared inbox.
Sub GetEmails()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Const NUM_DAYS As Long = 34
Dim OutlookApp As Outlook.Application
Dim i As Long
Dim Folder As Outlook.MAPIFolder
Dim itm As Object
Dim iRow As Long, oRow As Long, ws As Worksheet, sBody As String
Dim mailboxName As String, inboxName As String, subfolderName As String
mailboxName = "mailboxname"
inboxName = "Inbox"
subfolderName = "subfoldername"
Set OutlookApp = New Outlook.Application
On Error Resume Next
Set Folder = OutlookApp.Session.Folders(mailboxName) _
.Folders(inboxName).Folders(subfolderName)
On Error GoTo 0
If Folder Is Nothing Then
MsgBox "Source folder not found!", vbExclamation, _
"Problem with export"
Exit Sub
End If
Set ws = ThisWorkbook.Worksheets(1)
'add headers
ws.Range("A1").Resize(1, 4).Value = Array("Sender", "Subject", "Date", "Body")
iRow = 2
Folder.Items.Sort "Received"
For Each itm In Folder.Items
If TypeOf itm Is Outlook.MailItem Then 'check it's a mail item (not appointment, etc)
If Date - itm.ReceivedTime <= NUM_DAYS Then
sBody = Left(Trim(itm.Body), 150) 'first 150 chars of Body
sBody = Replace(sBody, vbCrLf, "; ") 'remove newlines
sBody = Replace(sBody, vbLf, "; ")
ws.Cells(iRow, 1).Resize(1, 4).Value = _
Array(itm.SenderName, itm.Subject, itm.ReceivedTime, sBody)
iRow = iRow + 1
End If
End If
Next itm
MsgBox "Outlook Mails Extracted to Excel"
End Sub
I tried changing "itm" to "item". It works on the regular inbox. The issue happens when I try to pull from a subfolder.
I tried Debug Print. I don't know if I'm putting it in the right place.
The 430 error happens on the line:
If Date - itm.ReceivedTime <= NUM_DAYS Then
If I try to pull 30 days worth of data, it will only pull like the last seven days. So it works but it is limited.
First of all, the Sort method deals with non-existsing property:
Folder.Items.Sort "Received"
You need to use the ReceivedTime property instead.
Second, the sorted collection is lost and you continue dealing with unsorted one.
Folder.Items.Sort "Received"
For Each itm In Folder.Items
Asking each time the Items property returns a new Items instance. So, you need to get an instance once and then re-use in the code. Only by following this way you will preserve the sorting order.
The 430 error happens on the line:
If Date - itm.ReceivedTime <= NUM_DAYS Then
The error code indicates that Class doesn't support Automation (Error 430) which don't tell us anything meaningful.
Anyway, calculating dates that way to get items for specific dates in Outlook is not the best and proper way. Instead, you need to consider using the Find/FindNext or Restrict methods of the Items class which allows getting/dealing with items that correspond to your conditions only. Read more about these methods in the articles I wrote for the technical blog:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
For example, you could use the following search criteria to get items for a specific timeframe:
'This filter uses urn:schemas:httpmail namespace
strFilter = AddQuotes("urn:schemas:httpmail:datereceived") _
& " > '" & datStartUTC & "' AND " _
& AddQuotes("urn:schemas:httpmail:datereceived") _
& " < '" & datEndUTC & "'"
See Filtering Items Using a Date-time Comparison for more information.

How to verify a mail from today exist?

I want to see if an email exists in a particular Outlook folder, using Excel VBA.
Sub Get_Calls_MTD_Data()
'making sure windows not jumping forth and back
Application.ScreenUpdating = False
Dim getCalls As Workbook
Dim releaseCalls As Workbook
Dim fPat As String
fPat = ThisWorkbook.Path
Dim SNDate As String
'The sheetname gets the date for the day name, so using variable for that
SNDate = Date
'-------------------
'Error handling doesn't work
'this dosent work any longer?
'If Dir(fPat & "\Outlookdata\calls mtd\" & Date & "." & "***") = "" Then
'
' MsgBox "does not find mail"
'
'Else
' making sure the windows dosen jump forth and back and no alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---------------------------
Set getCalls = Workbooks.Open(fPat & "\Outlookdata\Calls mtd\" & Date & "." & "*")
Set releaseCalls = Workbooks.Open(fPat & "\" & ThisWorkbook.Name)
getCalls.Activate
If Not IsEmpty(Range("G2").Value) = True Then
'finding last row
mylastagent = getCalls.Sheets(SNDate).Cells(Rows.Count, "G").End(xlUp).Row
getCalls.Sheets(SNDate).Range("G2:H" & mylastagent).Copy
releaseCalls.Activate
releaseCalls.Sheets("calls").Range("A1").PasteSpecial xlPasteValues
End If
getCalls.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("M3").Select
Update_Day_When_Calls_Updates
'Just the end if for the faulty error handling in the top
' End If
End Sub
Do I have to loop through the folder to find an email from today?
Also I started to get the prompt "clipboard has too much information, do you want to save it" in the end. Tried here for instance:
Disable clipboard prompt in Excel VBA on workbook close
Don't use strict date checks in Outlook. Instead, you need to use the Find/FindNext or Restrict methods of the Items class that allows getting only items that correspond to the search criteria. In the search criteria I'd recommend using less or greater conditions for dates.
Outlook evaluates date-time values according to the time format, short date format, and long date format settings in the Regional and Language Options applet in the Windows Control Panel. In particular, Outlook evaluates time according to that specified time format without seconds. If you specify seconds in the date-time comparison string, the filter will not operate as expected.
Although dates and times are typically stored with a date format, filters using the Jet and DAV Searching and Locating (DASL) syntax require that the date-time value to be converted to a string representation. In Jet syntax, the date-time comparison string should be enclosed in either double quotes or single quotes. In DASL syntax, the date-time comparison string should be enclosed in single quotes.
To make sure that the date-time comparison string is formatted as Microsoft Outlook expects, use the Visual Basic for Applications Format function (or its equivalent in your programming language).
'This filter uses urn:schemas:httpmail namespace
strFilter = AddQuotes("urn:schemas:httpmail:datereceived") _
& " > '" & datStartUTC & "' AND " _
& AddQuotes("urn:schemas:httpmail:datereceived") _
& " < '" & datEndUTC & "'"
See Filtering Items Using a Date-time Comparison for more information.
Read more about the Find/FindNext and Restrict methods in the articles I wrote for the technical blog:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
If you need to search for items in multiple folders you may consider using the AdvancedSearch method of the Application class, see Advanced search in Outlook programmatically: C#, VB.NET.
In the case of "today's mail", if processing time is noticeable, you can .Sort then stop processing once older mail is found.
Option Explicit
Sub Check_If_Mail_From_Today_Exists_Calls_Daily()
' Where code is not in Outlook
' Reference Microsoft Outlook nn.n Object Library
Dim ol As Outlook.Application
Dim fol As Outlook.Folder
Dim mi As Outlook.MailItem
Set ol = New Outlook.Application
Set fol = Session.Folders("Random#Email.com")
Set fol = fol.Folders("OutlookData")
Set fol = fol.Folders("Calls Daily")
Dim folItems As Items
Set folItems = fol.Items
folItems.Sort "[ReceivedTime]", True
Dim j As Long
For j = 1 To folItems.Count
If folItems(j).Class = olMail Then
Set mi = folItems(j)
If mi.Attachments.count > 1 Then
If Format(mi.ReceivedTime, "yyyy-mm-dd") = Format(Date, "yyyy-mm-dd") Then
Debug.Print mi.Subject
Debug.Print " " & Format(mi.ReceivedTime, "yyyy-mm-dd")
Else
'Older mail
Exit For
End If
End If
End If
Next
End Sub
.Restrict and .Find could be applied to all cases.
I managed to do it like this, probably not the best way, no certainly not the best way, but i solved it for my needs :) Thanks Niton.
Public RecivedToday As String
Sub Check_If_Mail_From_Today_Exists_Calls_Daily()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.folder
Dim i As Object
Dim mi As Outlook.MailItem
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.Folders("Random#Email.com").Folders("OutlookData").Folders("Calls Daily")
For Each i In fol.Items
If i.Class = olMail Then
Set mi = i
If mi.Attachments.Count > 1 And Format(mi.ReceivedTime, "yyyy-mm-dd") = Format(Date, "yyyy-mm-dd") Then
'Debug.Print Format(mi.ReceivedTime, "yyyy-mm-dd")
RecivedToday = Format(Date, "yyyy-mm-dd")
'Debug.Print RecivedToday
End If
End If
Next i
End Sub

Outlook VBA macro loop moving emails in unspecified batches

This is my first time using VBA with Outlook.
I got my code to work but encountered a strange problem as I added a step
The tasks are:
Save emails from subfolder1 to a network folder (this worked fine)
After saving, Move emails from subfolder1 to subfolder2 (adding this step caused issue)
(both subfolder1 and subfolder2 are subfolders in Outlook under the default Inbox folder)
Adding a single line of code for 2nd task caused a strange problem:
For the same 12 emails I was testing, the code would run without error messages but would only process few emails at a time. I would have to re-run code and it took 4 executions to finish all 12 emails.
Emails are processed in this order:
6 emails (the same one in same order every time)
3 emails (the same one in same order every time)
2 emails (the same one in same order every time)
1 email
There are no conditions in the code to stop it.
When I run the same code without adding the line for task#2, the macro processes all 12 emails in one go.
Commenting out this one line solves the "batchiness":
oMail.Move myFolder2
The remaining emails do get processed in subsequent runs; just not in one go.
Here's my code, borrowed mostly from: Macro to save selected emails of Outlook in Windows folder
Sub OutlookToDrive()
Dim myNameSpace As Outlook.NameSpace 'Object '(or Outlook.NameSpace)
Dim myFolder1 As Outlook.MAPIFolder 'Object '(or Outlook.MAPIFolder) folder to move FROM
Dim myFolder2 As Outlook.MAPIFolder 'Object '(or Outlook.MAPIFolder) Folder to move TO
Dim oMail As Object 'not specifying as 'mailobject' to include meeting invites
Dim sFileName As String
Dim dtdate As Date
Dim sDestinationFolder As String
Dim sFullPath As String
Dim sFolder1Name As String 'name of folder to move FROM
Dim sFolder2Name As String 'name of folder to move TO
Dim iCount As Integer
sDestinationFolder = "H:\PROD\Supplimentary_Info\"
'subfolders under the default Inbox folder:
sFolder1Name = "MoveFrom"
sFolder2Name = "MoveTo"
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder1 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(sFolder1Name)
Set myFolder2 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(sFolder2Name)
'initialize count
iCount = 0
For Each oMail In myFolder1.items
sFileName = oMail.Subject 'Use email subject as file name
'"ReplaceCharsForFileName" is a function that I'm not including; no issues
ReplaceCharsForFileName sFileName, "()" 'replace characters
dtdate = oMail.ReceivedTime
sFileName = Format(dtdate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & _
Format(dtdate, "-hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-" & sFileName & ".msg"
sFullPath = sDestinationFolder & "\" & sFileName
If Dir(sFullPath) = "" Then
iCount = iCount + 1
Debug.Print TypeName(oMail) & " " & sFileName
oMail.SaveAs sFullPath, olMSG 'save to specified path
DoEvents
oMail.Move myFolder2 'THIS LINE CAUSING ISSUE; BUT FINE IN BATCHES
DoEvents
End If
Next
MsgBox "Found " & iCount & " new emails in folder """ & myFolder1 & """ to save to path: " & vbNewLine & vbNewLine & sDestinationFolder
End Sub
In trying to diagnose the problem, made a list of emails in batches they appear using debug.print list. (Bold prefix number is the order they sit in the mail folder, bold prefix text is email type)
I changed the number of total emails for testing. New batches remained consistent the number of times I repeated:
Total 15 email; batches 8, 4, 2, 1
Total 6 emails; batches 3, 2, 1
Total 5 emails; batches 3, 1, 1
Total 3 emails; batches 2, 1
Total 2 emails; Both went through. yeah!
(The 15 count group was made by adding 3 new emails to original 12 emails in folder1. The 12 emails changed order in which they were processed within new test group. But re-running the macro always gave the same emails in same new batches every time I tested)
Try this:
For i = myFolder1.Items.count -1 to 0 step -1
Set oMail = myFolder1.Items(i)
'Do your thing
Next i
I suspect your loop skips an item because you remove your item from the folder.
Here's modified response posted by Alex de Jong.
Code works nicely when loop is changed to:
For i = myFolder1.Items.count to 1 step -1
Set oMail = myFolder1.Items(i)
'Do your thing
Next i

Move specific mails from one folder to another

in Outlook I would like to have a FollowUp-Solution that checks a specific folder (Source Folder) if there are mails older than 1 days and moves them in another specific folder (Target Folder).
My problem is that it seems as my code isn't looping the SourceFolder properly. Some mails are moved but some old mails are still in the SourceFolder.
When I restart the Code some of the remaining mails are moved now but still some remain in the SourceFolder.
I tried to loop the Items in other ways (with; for each; do) but I guess my vba understanding is too bad to get a working solution.
Sub MoveFollowUpItems()
Dim FolderTarget As Folder
Dim FolderSource As Folder
Dim Item As Object
Dim FolderItems As Outlook.Items
Set FolderTarget = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set FolderSource = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("FollowUp")
Set FolderItems = FolderSource.Items
For Each Item In FolderItems
If Item.ReceivedTime < Date - 1 Then '
Item.Move FolderTarget
End If
Next
End Sub
Does anyone know how to handle the propper looping?
For Each Loop is a great but When moving/deleting items Loop Through in Reverse Order you know count down (ie 3,2,1). In order to do this, you can incorporate Step -1 into your loop statement.
Also to improve your loop try using Items.Restrict Method (Outlook) on your date filter
Example
Option Explicit
Sub MoveFollowUpItems()
Dim FolderTarget As Folder
Dim FolderSource As Folder
Dim FolderItems As Outlook.Items
Set FolderTarget = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set FolderSource = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("FollowUp")
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " <= 'Date - 1' "
Set FolderItems = FolderSource.Items.Restrict(Filter)
Debug.Print FolderItems.Count
Dim i As Long
For i = FolderItems.Count To 1 Step -1
Debug.Print FolderItems(i) 'Immediate Window
' FolderItems(i).Move FolderTarget
Next
End Sub

For Each loop: Just deletes the very first attachment

I've been trying to delete the attachments in Outlook after copying them using for each loop. It just deletes the very first attachment after copying it but does not go for the second attachment to work on! It just goes down to the End Sub.
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
'If (Msg.SenderName = "Name Of Person") And _
'(Msg.Subject = "Subject to Find") And _
'(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim olAttch As Outlook.Attachment
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:\Users\pkshahbazi\Documents\EmailAttachments\"
Set myAttachments = Msg.Attachments
For Each olAttch In myAttachments
Att = olAttch.DisplayName
If Right(olAttch.FileName, 3) = "zip" Then
olAttch.SaveAsFile attPath & Att
olAttch.Delete
End If
Next olAttch
Msg.UnRead = False
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
I figured out that the OlAttch.delete statement confuses the For Each loop.
Any idea how I can delete the attachments.
In your previous question we changed from an indexed loop to a non-indexed loop, because you did not have any .Delete requirement. Unfortunately, deleting items from a collection requires an indexed iteration.
This is because, when you have 3 items:
Item 1 = Attachment 1
Item 2 = Attachment 2
Item 3 = Attachment 3
Then when you delete the first item (Item 1/Attachment 1), it takes you to item 2, but when the delete happens, you are left with the collection that looks like:
Item 1 = Attachment 2
Item 2 = Attachment 3
So your loop will delete items 1 and 3, but it will never touch item 2.
The simplest way to fix this for you, without using an indexed loop and re-writing your script, is to just add another loop to do the delete method.
#Enderland provides the example for this. I will not duplicate his effort, but I did want to explain what is happening for you. This is always the case when deleting items from a collection, you have to step through the collection in reverse order.
Try this. I added code/comments to iterate through and remove all the attachments after you do your saving. The reasons you should do this are explained very well here by David Zemens.
You also should get in the habit of saving messages you modify in Outlook VBA as sometimes this is important, sometimes it's not, but it can confuse the heck out of you if you don't use Save when you need to.
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:\Users\pkshahbazi\Documents\EmailAttachments\"
Set myAttachments = Msg.Attachments
For Each olAttch In myAttachments
Att = olAttch.DisplayName
If Right(olAttch.FileName, 3) = "zip" Then
olAttch.SaveAsFile attPath & Att
'olAttch.Delete
End If
Next olAttch
'iterate through all attachments, going backwards
dim j as integer
For j = Msg.Attachments.Count To 1 Step -1
Msg.Attachments.Remove (j)
Next j
'make sure to save your message after this
Msg.save
Msg.UnRead = False
End If