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.
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
User has a column with names (or name, surname) to send email.
When there are several with the same name and surname the macro is selecting the first matching.
How can I check if for a specific name there is more than one email addresse, to perform another function?
My code to get email address.
Dim myolApp As Outlook.Application
Dim myNameSpace As Namespace
Dim myAddrList As AddressList
Dim myAddrEntry As AddressEntry
Dim AliasName As String
Dim c As Range
Dim EndRow As Integer, n As Integer
Dim exchUser As Outlook.ExchangeUser
Set myolApp = CreateObject("Outlook.Application")
Set myNameSpace = myolApp.GetNamespace("MAPI")
Set myAddrList = myNameSpace.AddressLists("Global Address List")
EndRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range("A1:A" & CStr(EndRow))
AliasName = LCase(Trim(c))
c = AliasName
Set myAddrEntry = myAddrList.AddressEntries(AliasName)
Set exchUser = myAddrEntry.GetExchangeUser
On Error Resume Next
c.Offset(0, 4) = exchUser.PrimarySmtpAddress
Next c
End Sub
You can use formula in Excel sheet =COUNTIF(column_range, name_surname) and then you can read values with your VBA code. When result of formula is >1 then you do some other procedure.
Hopefully all your names are sorted in some way first name and then surname or something, sometimes happens that they are mixed and then this aproach might not work correctly.
There nothing really in Outlook Object Model that would help you with ambiguous names. You can of course loop through all items in GAL (Namespace.GetGlobalAddressList), but large GAL containers would not even let you loop through its entries; and if you can loop, it can take a very long time (as in tens of minutes).
Extended MAPI (C++ or Delphi) lets you either retrieve the list of ambiguous names or display the dialog box that lets you select one entry from the list of ambiguous names. If VBA is your only option, you can use Redemption (I am its author) which exposes that MAPI functionality:
set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = myolApp.Session.MAPIOBJECT
'silently retrieve the list matches
set AdrrEntries = Session.AddressBook.GAL.ResolveNameEx("john")
MsgBox AdrrEntries.Count & " names were returned by ResolveNameEx:"
for each AE in AdrrEntries
MsgBox AE.Name
next
'allow Outlook to display the ambiguous name dialog if necessary
set Match = Session.AddressBook.ResolveName("john", true)
if not (match is Nothing) Then
MsgBox match.Name
End If
I have code to extract all email attachments from specific email folder.
I want to change to extract email attachments starting from a date which I enter in a dialog box. I want to extract email attachments from emails received in the last seven days.
Sub Extract_emails()
Dim OlApp As Object
Dim OlMail As Object
Dim OlItems As Object
Dim Olfolder As Object
Dim J As Integer
Dim strFolder As String
Set OlApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set OlApp = CreateObject("Outlook.Application")
End If
strFolder = ThisWorkbook.Path & "\Extract"
Set Olfolder = OlApp.getnamespace("MAPI").Folders("MyEmailAddress").Folders("Inbox")
Set OlItems = Olfolder.Items
For Each OlMail In OlItems
If OlMail.Attachments.Count > 0 Then
For J = 1 To OlMail.Attachments.Count
OlMail.Attachments.Item(J).SaveAsFile strFolder & "\" & OlMail.Attachments.Item(J).Filename
Next J
End If
Set OlApp = Nothing
Set OlMail = Nothing
Set OlItems = Nothing
Set Olfolder = Nothing
Next
MsgBox ("Done")
End Sub
I need to extract only xlsx attachments (vendor sends Excel and pdf documents) and to save them in folder. After I need to open saved Excel file and to copy data in base and to close saved xlsx. I don't know name of xlsx file (usually it is our company name and some numbers) but every report has sheets "shipped" from which I copy data in base. No one reads these emails that's why I tried with unread emails.
Code which works with F8 but not with F5.
Set OlApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set OlApp = CreateObject("Outlook.Application")
End If
strFolder = ThisWorkbook.Path & "\Extract"
Set Olfolder = OlApp.getnamespace("MAPI").Folders("Freight.Invoice#omega.com").Folders("Inbox")
Set OlItems = Olfolder.Items
For Each OlMail In OlItems
If OlMail.UnRead = True Then
If OlMail.Attachments.Count > 0 Then
For J = 1 To OlMail.Attachments.Count
FilePath = strFolder & "\" & OlMail.Attachments.Item(J).FileName
OlMail.Attachments.Item(J).SaveAsFile FilePath
If Right(FilePath, 4) = "xlsx" Then
runit FilePath
For I = 1 To Worksheets.Count
If Worksheets(I).Name = "Shipped" Then
Worksheets("Shipped").Activate
Set wsCopy = Worksheets("Shipped")
Set wsDest = Workbooks("Extract
emails.xlsm").Worksheets("DATA")
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count,
"B").End(xlUp).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count,
"B").End(xlUp).Offset(1).Row
wsCopy.Range("B4:K" & lCopyLastRow).Copy _
wsDest.Range("B" & lDestLastRow)
Worksheets("Shipped").Activate
ActiveWorkbook.Close savechanges:=False
End If
Next
End If
Next J
End If
End If
Next
For Each OlMail In OlItems
If OlMail.UnRead = True Then
OlMail.UnRead = False
DoEvents
OlMail.Save
End If
Set OlApp = Nothing
Set OlMail = Nothing
Set OlItems = Nothing
Set Olfolder = Nothing
Next
MsgBox ("Done")
End Sub
Sub runit(FilePath As String)
Dim Shex As Object
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Set Shex = CreateObject("Shell.Application")
Shex.Open (FilePath)
End Sub
This is a tutorial rather than a direct answer to your question. I cover everything you need to know. I believe you will find this approach more useful than “a run this code and it will work” answer. I hope I have explained everything adequately. Come back with questions if necessary.
You need to compare an email’s ReceivedTime against the oldest required date. You say you intend to enter the oldest required date and you also say you want the last seven days. There may be an alternative. Type the following commands (except the comments) in you Immediate Window.
? now() The current date and time
? datevalue(now()) The current date
? dateadd("d",-7,now()) Seven days before now
? dateadd("d",-7,datevalue(now())) Seven days ago
? dateadd("ww",-1,datevalue(now())) One week ago
Do any of these expressions give you the date you want? In DateAdd, “d” and “ww” are intervals with “d” meaning days and “ww” meaning weeks. There are other values such as “w” meaning weekdays. Experiment if one of these expressions gives you almost what you want.
Other possibilities include setting a category or a custom property when the attachments are saved.
If you have not done so already, open your workbook and the VBA Editor. Click [Tools] then [References…]. Is “Microsoft Outlook nn.n Object Library” near the top of the list and ticked? Note: “nn.n” depends on the version of Office you are using. If this library is not listed and ticked, scroll down until you find it and click the little box to tick it. This gives your workbook access to Outlook data items so you do not have to specify so many Objects.
Now create a new module and copy the code below to it. If you run macro Demo(), you will get output like this:
Oldest additions to Inbox
[14/12/2019 18:21:21] [28/12/2019 05:05:00] [08/01/2020 18:37:09] [28/03/2019 16:16:12] [21/03/2019 14:00:08]
[14/06/2018 21:02:34] [03/02/2020 09:29:38] [06/03/2020 17:03:50] [11/03/2020 13:43:33] [12/03/2020 00:07:53]
[13/03/2020 08:46:58] [13/03/2020 17:31:23] [14/03/2020 03:42:53] [14/03/2020 08:07:35] [14/03/2020 08:58:11]
[15/03/2020 19:43:16] [16/03/2020 16:48:40] [16/03/2020 20:39:58] [17/03/2020 11:14:29] [18/03/2020 01:43:37]
Newest additions to Inbox
[18/03/2020 01:43:37] [17/03/2020 11:14:29] [16/03/2020 20:39:58] [16/03/2020 16:48:40] [15/03/2020 19:43:16]
[14/03/2020 08:58:11] [14/03/2020 08:07:35] [14/03/2020 03:42:53] [13/03/2020 17:31:23] [13/03/2020 08:46:58]
[12/03/2020 00:07:53] [11/03/2020 13:43:33] [06/03/2020 17:03:50] [03/02/2020 09:29:38] [14/06/2018 21:02:34]
[21/03/2019 14:00:08] [28/03/2019 16:16:12] [08/01/2020 18:37:09] [28/12/2019 05:05:00] [14/12/2019 18:21:21]
Newest emails in Inbox
[20/03/2020 12:16:47] [20/03/2020 00:00:14] [19/03/2020 17:51:21] [19/03/2020 17:06:38] [19/03/2020 10:19:36]
[18/03/2020 16:21:25] [18/03/2020 01:43:37] [17/03/2020 11:14:29] [16/03/2020 20:39:58] [16/03/2020 16:48:40]
[15/03/2020 19:43:16] [14/03/2020 08:58:11] [14/03/2020 08:07:35] [14/03/2020 03:42:53] [13/03/2020 17:31:23]
[13/03/2020 08:46:58] [12/03/2020 00:07:53] [11/03/2020 13:43:33] [06/03/2020 17:03:50] [03/02/2020 09:29:38]
Oldest emails in Inbox
[14/06/2018 21:02:34] [21/03/2019 14:00:08] [28/03/2019 16:16:12] [14/12/2019 18:21:21] [28/12/2019 05:05:00]
[08/01/2020 18:37:09] [03/02/2020 09:29:38] [06/03/2020 17:03:50] [11/03/2020 13:43:33] [12/03/2020 00:07:53]
[13/03/2020 08:46:58] [13/03/2020 17:31:23] [14/03/2020 03:42:53] [14/03/2020 08:07:35] [14/03/2020 08:58:11]
[15/03/2020 19:43:16] [16/03/2020 16:48:40] [16/03/2020 20:39:58] [17/03/2020 11:14:29] [18/03/2020 01:43:37]
Things to note:
I have Dim OutApp As New Outlook.Application. The “New” says create the reference rather than just create a data item for a reference. This means I do not need GetObject or CreateObject. Outlook will only allow one occurrence of itself at a time so my “New” or your CreateObject will reference an existing occurrence or create a new one as necessary. I also have OutApp.Quit at the end. This closes Outlook whether or not it was already open. I don’t use Outlook while using Excel workbooks to access Outlook, so I want Outlook to be closed. If you care, use your Get or Create code but record which was successful, so you know if Quit is needed.
I have named my data item OutApp instead of olApp. Outlook uses the prefix “ol” for its constants, so I avoid this prefix in case my name matches one of Outlook’s.
I have used Session instead of GetNamespace("MAPI"). They are just different ways of achieving the same effect.
ItemsInbox is a “Collection”; what other languages call a “List”. A collection is like an array except you can add new entries before any existing entries, in the middle or after any existing entries. Any existing entries can be removed.
Outlook adds new emails at the end of the collection. So, if you read from first to last, the first email is the one that has been in Inbox longest first. If you read from last to first, the first email is the one that was added to Inbox most recently. This suggests that you can read from last to first and see the most recent emails first and you can stop when you reach an out-of-range email. However, if you move an old email from Inbox to another folder then move it back, it will not be returned to its old position; instead it will be added to the end.
In the macro below, I first list the ReceivedTime of twenty emails from first to last then from last to first. You may see that some are out of sequence.
I then list ReceivedTime of twenty emails after sorting by ReceivedTime in descending then ascending sequence.
Study the four blocks of dates. In particular, note the different sequences. I believe the code behind the third block of dates will be the most suitable for you.
I think I have covered everything but, as I said, come back will questions if necessary and I will repair any deficiencies.
Option Explicit
' Needs reference to "Microsoft Outlook n.nn Object Library"
' where n.nn depends on the version of Outlook you are using.
Sub Demo()
Dim FldrInbox As Outlook.Folder
Dim InxICrnt As Long
Dim InxIMax As Long
Dim ItemsInbox As Outlook.Items
Dim NumOnLine As Long
Dim OutApp As New Outlook.Application
Set FldrInbox = OutApp.Session.Folders("a.j.dallimore#xxxxxxx.com").Folders("Inbox")
Set ItemsInbox = FldrInbox.Items
If ItemsInbox.Count > 20 Then
InxIMax = 20
Else
InxIMax = ItemsInbox.Count
End If
Debug.Print "Oldest additions to Inbox"
NumOnLine = 0
For InxICrnt = 1 To InxIMax
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
Debug.Print "Newest additions to Inbox"
NumOnLine = 0
For InxICrnt = InxIMax To 1 Step -1
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
ItemsInbox.Sort "ReceivedTime", True
Debug.Print "Newest emails in Inbox"
NumOnLine = 0
For InxICrnt = 1 To InxIMax
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
ItemsInbox.Sort "ReceivedTime", False
Debug.Print "Oldest emails in Inbox"
NumOnLine = 0
For InxICrnt = 1 To InxIMax
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
Set ItemsInbox = Nothing
OutApp.Quit
Set OutApp = Nothing
End Sub
Revised requirement
Every week or so, you receive an email from a vendor containing an invoice in both PDF and XLSX formats. An Outlook rule recognises that email and moves it to a dedicated folder. Your team is not interested in the PDF version. The XLSX workbook does not have a consistent name. However, it consistently contains a worksheet “Shipped” that contains data that would be useful to your team. At present, you will not attempt to process that data by macro but you would like it consolidated into your own workbook so it can be viewed conveniently by the team. At present, the desired format is:
Columns B to K of row 4+ of worksheet “Shipped” for week starting 1Mar20
: : : : :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 8Mar20
: : : : :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 15Mar20
: : : : :
Reviewed ideas on achieving requirement
If you had asked a few months ago, I would have suggested linking the macro to the rule with “Run a script”. Microsoft has decided that “Run a script” is dangerous and it is no longer available by default. There is online help which explains how to make “Run a script” available but I suggest you wait until you are more experienced before attempting this.
I would suggest a revised format for the consolidated data:
Data from email received 2Mar20 9:10
Entire contents of worksheet “Shipped”
Data from email received 9Mar20 9:30
Entire contents of worksheet “Shipped”
Data from email received 16Mar20 9:20
Entire contents of worksheet “Shipped”
The heading rows mean there is no possible confusion about where one week’s data ends and another starts. Including the heading rows from the worksheet and all columns means that if they add another column it will still be included in your consolidation and you will have a warning if they change the sequence.
The macro does not have to be in the same workbook as the data. I usually keep the macro and the data separate for this type of task. The data is updated regularly, but the macro is only updated occasionally. For example, I download my bank statements every month and merge them into a continuous statement running back years. I only change the macro when they change the format of the download.
You do not need code that recognises the email by, for example, testing the UnRead property because the email of interest will be the latest in the dedicated folder. There is a possibility that you will call the macro before the new email has arrived, so the macro looks at last week’s email. If it checks the latest header within the consolidated worksheet, it will know it has an old workbook and can exit without making changes.
The following is my suggestion. Do not worry if you do not know how to achieve some of my ideas because I do know how to.
You have two workbooks with names like “Consolidation Macros V02.xlsm” and “Consolidated Data V25.xlsx”. Whenever a new invoice arrives, you open the latest consolidation macros workbook and start the consolidate macro. It is possible to start macros automatically when a workbook is opened but I suggest we leave that for the moment. The macro opens the latest data workbook and notes the date of the most recent addition. It accesses Outlook, finds the latest invoice email and checks its date against the date of the most recent addition. Unless the date of the latest invoice email is later that the latest addition, the macro terminates. If the date is satisfactory, the macro finds the XLSX attachment and saves it to disc. It opens that workbook, checks for worksheet “Shipped” and adds its contents to the bottom of worksheet “Shipped” within the latest consolidated data worksheet and saves the workbook with the next version number.
You will have noticed that I have a version number for each workbook. During my working life I saw too many disasters because people did not save a new version whenever they updated a file. I can drop the version numbers if you do not want them.
Do you think the above matches your requirement?
I have finished testing the system I proposed in my original answer. It is not exactly the same, for reasons I will explain later, but it matches in all important details. I am posting it as new answer so there is no confusion.
To test it, I created some workbooks which I named Test1, Test2, Test3 and so on. Within each workbook I created a worksheet “Shipped”. Each of these worksheets had a different number of rows and columns. Each cell contained “T-R-C” where T was the test number, R was the row and C was the column. These values made it very easy to check that data was copied correctly from the attachments to the consolidated worksheet. After deleting most of the rows so the structure was visible, the result of consolidation was:
You can see that my code can combine all the rows and all the columns from as many emails as required. My emails are not a week apart but that is not important.
My recommendation is that you try my macro as it is. You can then discuss the appearance with your colleagues, and we can then discuss how to change my macro to match your exact requirements.
Create a new disc folder and within it create two new workbooks: one ordinary (xlsx) and one macro-enabled (xlsm).
Name the ordinary workbook “Consolidated Data.xlsx”. Within it, rename the default worksheet as “Shipped”.
The name of the macro-enabled workbook is unimportant as is the name of the worksheet. Within the VBA Editor, create three modules and name then "LibExcel", "LibOutlook" and "ModConsolidate". Naming modules is not essential but dividing macros up by purpose and naming modules for those purposes makes life much easier.
I will tell you to move the code below to one of these three modules.
Module "ModConsolidate" is for code I have written specifically for your requirement. Module "LibExcel" is for code from my library of Excel related routines. Module "LibOutlook" is for code from my library of Outlook related routines.
When I end a project, I look through it to see if there is any code I might wish to use again. If there is, I extract it and save it in "PERSONAL.XLSB" which I use as my library. Any macro saved in this workbook is available to all other workbooks. Don’t bother today but when you have some spare time look up how to create "PERSONAL.XLSB". When you have created it, move modules "LibExcel" and "LibOutlook" to it. In "LibExcel", I have routines to find the last used row and column of a worksheet and to check is a named worksheet exists. In "LibOutlook" I have routines for opening and closing an instance of Outlook from Excel.
When I start a project, I look through my library for routines that might be appropriate. If necessary, a routine will be enhanced to provide functionality that I had not needed before. The result is I have a library of useful functions that get more powerful, and larger, as I complete each project.
I said I would have version numbers on the workbook I created for you. Unfortunately, the macros that handle this and related functionality are too large to post to Stack Overflow.
This code should go in LibExcel:
' Routines useful with Excel
Option Explicit
Public Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
ByRef ColLast As Long)
' Sets RowLast and ColLast to the last row and column with a value
' in worksheet Wsht
' The motivation for coding this routine was the discovery that Find by
' previous row found a cell formatted as Merge and Center but Find by
' previous column did not.
' I had known the Find would miss merged cells but this was new to me.
' Dec16 Coded
' 31Dec16 Corrected handling of UserRange
' 15Feb17 SpecialCells was giving a higher row number than Find for
' no reason I could determine. Added code to check for a
' value on rows and columns above those returned by Find
' 25Jun17 Found column with value about that found by Find
Dim ColCrnt As Long
Dim ColLastFind As Long
Dim ColLastOther As Long
Dim ColLastTemp As Long
Dim ColLeft As Long
Dim ColRight As Long
Dim Rng As Range
Dim RowIncludesMerged As Boolean
Dim RowBot As Long
Dim RowCrnt As Long
Dim RowLastFind As Long
Dim RowLastOther As Long
Dim RowLastTemp As Long
Dim RowTop As Long
With Wsht
Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
If Rng Is Nothing Then
RowLastFind = 0
ColLastFind = 0
Else
RowLastFind = Rng.Row
ColLastFind = Rng.Column
End If
Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
If Rng Is Nothing Then
Else
If RowLastFind < Rng.Row Then
RowLastFind = Rng.Row
End If
If ColLastFind < Rng.Column Then
ColLastFind = Rng.Column
End If
End If
Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
If Rng Is Nothing Then
RowLastOther = 0
ColLastOther = 0
Else
RowLastOther = Rng.Row
ColLastOther = Rng.Column
End If
Set Rng = .UsedRange
If Rng Is Nothing Then
Else
If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
RowLastOther = Rng.Row + Rng.Rows.Count - 1
End If
If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
ColLastOther = Rng.Column + Rng.Columns.Count - 1
End If
End If
If RowLastFind < RowLastOther Then
' Higher row found by SpecialCells or UserRange
Do While RowLastOther > RowLastFind
ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
Debug.Assert False
' Is this possible
' Row after RowLastFind has value
RowLastFind = RowLastOther
Exit Do
End If
RowLastOther = RowLastOther - 1
Loop
ElseIf RowLastFind > RowLastOther Then
Debug.Assert False
' Is this possible
End If
RowLast = RowLastFind
If ColLastFind < ColLastOther Then
' Higher column found by SpecialCells or UserRange
Do While ColLastOther > ColLastFind
RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
'Debug.Assert False
' Column after ColLastFind has value
' Possible causes:
' * Find does not recognise merged cells
' ' Find does not examine hidden cells
ColLastFind = ColLastOther
Exit Do
End If
ColLastOther = ColLastOther - 1
Loop
ElseIf ColLastFind > ColLastOther Then
Debug.Assert False
' Is this possible
End If
ColLast = ColLastFind
End With
End Sub
Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String) As Boolean
' Returns True if Worksheet WshtName exists within
' * if Wbk Is Nothing the workbook containing the macros
' * else workbook Wbk
' 21Aug16 Coded by Tony Dallimore
' 14Feb17 Coded alternative routine that cycled through the existing worksheets
' matching their names against WshtName to check if use of "On Error Resume Next"
' was the faster option. I needed to call the routines 6,000,000 times each to
' get an adequate duration for comparison. This version took 33 seconds while
' the alternative took 75 seconds.
' 21Feb20 Added "As Boolean" to declaration. Do not understand how routine worked
' without it.
Dim WbkLocal As Workbook
Dim Wsht As Worksheet
If Wbk Is Nothing Then
Set WbkLocal = ThisWorkbook
Else
Set WbkLocal = Wbk
End If
Err.Clear
On Error Resume Next
Set Wsht = WbkLocal.Worksheets(WshtName)
On Error GoTo 0
If Wsht Is Nothing Then
WshtExists = False
Else
WshtExists = True
End If
End Function
This code should go in LibOutlook
' Routines useful with Outlook.
Option Explicit
Public Sub OutAppClose(ByRef OutApp As Outlook.Application, ByVal Created As Boolean)
' If Created is True, quit the current instance if Outlook.
If Created Then
OutApp.Quit
End If
Set OutApp = Nothing
End Sub
Public Function OutAppGetCreate(ByRef Created As Boolean) As Outlook.Application
' Return a reference to the Outlook Application.
' Set Created to True if the reference is to a new application and to
' False if the reference is to an existing application.
' If Nothing is returned, the routine has been unable to get or create a reference.
' Only one instance of Outlook can be running. CreateObject("Outlook.Application")
' will return a reference to the existing instance if one is already running or
' will start a new instance if one is not running. The disadvantage of using
' CreateObject, is the caller does not know if Outlook was running so does not know
' whether or not to quit Outlook when it has finished using Outlook. By setting
' Created, this routine allows the caller to only quit if this is appropriate.
Set OutAppGetCreate = Nothing
On Error Resume Next
Set OutAppGetCreate = GetObject(, "Outlook.Application")
On Error GoTo 0
If OutAppGetCreate Is Nothing Then
On Error Resume Next
Set OutAppGetCreate = CreateObject("Outlook.Application")
On Error GoTo 0
If OutAppGetCreate Is Nothing Then
Call MsgBox("I am unable to access Outlook", vbOKOnly)
Exit Function
End If
Created = True
Else
Created = False
End If
End Function
This code should go in ModConsolidate:
Option Explicit
' * Need reference to "Microsoft Outlook nn.n Object Library"
' where nn.n depends on the version of Office being used.
' * Needs reference to "Microsoft Scripting Runtime"
Const HeaderForData As String = "Data from email received"
Const WbkConName As String = "Consolidated Data.xlsx"
Const WshtName As String = "Shipped" ' Also used for name of workbooks
Sub ConsolidateDataFromShippedWshts() ()
' Outlook used "ol" as a prefix for its constants. I do not use the same
' prefix to avoid a clash.
Dim OutApp As Outlook.Application
Dim OutAppCreated As Boolean
Dim ColConLast As Long ' Last column of worksheet "Shipped" in consolidated workbook
Dim ColSrcLast As Long ' Last column of worksheet "Shipped" in source workbook
Dim DateLatestExisting As Date ' Date of last block of data in consolidated workbook
Dim DateStr As String ' Date extracted from header row
Dim FldrShipped As Outlook.Folder ' Outlook Folder containing source emails
Dim InxA As Long ' Index into attachments
Dim InxI As Long ' Index into mail items
Dim InxW As Long ' Into into WbkSrcNames
Dim ItemsShipped As Items ' Items in source folder
Dim Path As String ' Disc folder containing workbooks
Dim Rng As Range ' Various uses
Dim RowConCrnt As Long ' Current row of worksheet "Shipped" in consolidated workbook
Dim RowConLast As Long ' Last row of worksheet "Shipped" in consolidated workbook
Dim RowSrcLast As Long ' Last row of worksheet "Shipped" in source workbook
Dim WbkCon As Workbook ' Consolidated workbook
Dim WbkMacros As Workbook ' This workbook
Dim WbkSrc As Workbook ' Workbook extracted from email
Dim WbkSrcName As String ' Name of workbook extracted from email
Dim WbkSrcNameDates As Collection ' Collection of the names and dates of workbooks extracted from emails
Dim WshtCon As Worksheet ' Worksheet "Shipped" in consolidated workbook
Dim WshtSrc As Worksheet ' Worksheet "Shipped" in source workbook
Application.ScreenUpdating = False
Set WbkMacros = ThisWorkbook
Path = WbkMacros.Path
' ### Change if you want a different name for consolidated workbook
Set WbkCon = Workbooks.Open(Path & "\" & WbkConName)
Set WshtCon = WbkCon.Worksheets(WshtName)
' Find last used row of consolidated worksheet
Call FindLastRowCol(WshtCon, RowConLast, ColConLast)
If RowConLast = 0 Then
' No data added yet
DateLatestExisting = 0
Else
' Search up for header for last block of data added
With WshtCon
Set Rng = .Columns(1).Find( _
What:=HeaderForData, After:=.Cells(RowConLast + 1, 1), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False, SearchFormat:=False)
If Rng Is Nothing Then
Debug.Assert False
' It should not be possible to be here. Either the worksheet is empty
' and RowColLast = 0 or one or more blocks of data, each with a header,
' have been added. It appears the worksheet is not as it should be.
DateLatestExisting = 0
Else
DateStr = Mid$(.Cells(Rng.Row, 1).Value, Len(HeaderForData) + 2)
If IsDate(DateStr) Then
DateLatestExisting = DateValue(DateStr) + TimeValue(DateStr)
Else
Debug.Assert False
' It should not be possible to be here. The text after HeaderForData
' should be a valid date. It appears the worksheet is not as it should be.
DateLatestExisting = 0
End If
End If
End With
End If
Set OutApp = OutAppGetCreate(OutAppCreated)
If OutApp Is Nothing Then
' OutAppGetCreated() failed. The user has already been told.
Exit Sub
End If
' ### Change to access folder where you store these emails
Set FldrShipped = OutApp.Session.Folders("MyName#MyIsp").Folders("Test")
' Create list of items in folder sorted by ReceivedTime
Set ItemsShipped = FldrShipped.Items
ItemsShipped.Sort "ReceivedTime", True
Set WbkSrcNameDates = New Collection
' Read items, newest first, until reach an item at or before DateLatestExisting
' Save xlsx attachment, if any, and record names in WbkSrcNames
For InxI = 1 To ItemsShipped.Count
If TypeName(ItemsShipped(InxI)) = "MailItem" Then
If ItemsShipped(InxI).ReceivedTime <= DateLatestExisting Then
' No more unprocessed emails
Exit For
End If
' Save Xlsx attachment, if any
For InxA = 1 To ItemsShipped(InxI).Attachments.Count
If LCase(Right$(ItemsShipped(InxI).Attachments(InxA).FileName, 5)) = ".xlsx" Then
' Have found required attachment. Save with name based on date received
WbkSrcName = WshtName & " " & Format(ItemsShipped(InxI).ReceivedTime, "yymmdd hhmmss") & ".xlsx"
ItemsShipped(InxI).Attachments(InxA).SaveAsFile Path & "\" & WbkSrcName
WbkSrcNameDates.Add VBA.Array(WbkSrcName, ItemsShipped(InxI).ReceivedTime)
Exit For
End If
Next
End If
Next
Call OutAppClose(OutApp, OutAppCreated)
If WbkSrcNameDates.Count = 0 Then
' No new emails with xlsx attachments
WbkCon.Close SaveChanges:=False
Call MsgBox("No new emails containing an xlsx attachment", vbOKOnly)
Set WshtCon = Nothing
Set WbkCon = Nothing
Set WbkMacros = Nothing
Exit Sub
End If
' WbkSrcNameDates contains the names and received dates of the new workbooks
' with the newest first.
' Extract names in reverse order (oldest first) and add contents of worksheet
' "Shipped" to bottom of worksheet "Shipped" of consolidated workbook
For InxW = WbkSrcNameDates.Count To 1 Step -1
Set WbkSrc = Workbooks.Open(Path & "\" & WbkSrcNameDates(InxW)(0))
If WshtExists(WbkSrc, WshtName) Then
' Worksheet "Shipped" exists
Set WshtSrc = WbkSrc.Worksheets(WshtName)
Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)
RowConCrnt = RowConLast + 1 ' Advance to first free row
With WshtCon.Cells(RowConCrnt, 1)
.Value = HeaderForData & " " & Format(WbkSrcNameDates(InxW)(1), "d-mmm-yy h:mm:ss")
.Font.Bold = True
End With
RowConCrnt = RowConCrnt + 1
With WshtSrc
.Range(.Cells(1, 1), .Cells(RowSrcLast, ColSrcLast)).Copy _
Destination:=WshtCon.Cells(RowConCrnt, 1)
End With
RowConLast = RowConCrnt + RowSrcLast - 1
End If
WbkSrc.Close SaveChanges:=False
Next
' Position cursor to header for latest data
Application.ScreenUpdating = True
WshtCon.Activate
WshtCon.Cells(RowConLast - RowSrcLast, 1).Select
Application.Goto ActiveCell, True
WbkCon.Close SaveChanges:=True
Set WshtCon = Nothing
Set WbkCon = Nothing
Set WbkMacros = Nothing
End Sub
At the top of ModConsolidate, it says it needs references to "Microsoft Outlook nn.n Object Library", where nn.n depends on the version of Office being used, and "Microsoft Scripting Runtime". If you are unsure what that means, ask and I will add an explanation.
Line 173 of ModConsolidate is Set FldrShipped = OutApp.Session.Folders("MyName#MyIsp").Folders("Test"). This references the Outlook folder in which I placed the test emails. Replace my Outlook folder with the one holding these emails on your system. Place as many of these emails as you have in that folder.
Run macro ConsolidateDataFromShippedWshts(). This macro will:
Open workbook “Consolidated Data.xlsx”
Check worksheet “Shipped” and find that it is empty.
Open Outlook if not already open.
Access the Outlook folder and extract the workbook from every email because worksheet “Shipped” is empty. Workbooks will be saved with the name “Shipped yymmdd hhmmss.xlsx”. If worksheet “Shipped” had not been empty, it would only have extracted workbooks from the newer emails.
Close Outlook if it was not open.
Open each of the new workbooks in turn and add the contents of their worksheet “Shipped” to worksheet “Shipped” within “Consolidated Data.xlsx”.
I have tested macro ConsolidateDataFromShippedWshts() thoroughly but only with my fake workbooks and emails. It should work properly unless I have misunderstood the nature of your workbooks and emails. If something goes wrong, describe the problem to me and I will try to diagnose the cause.
If everything works as expected. Review “Consolidated Data.xlsx” and discuss it with your colleagues. While you are doing that, I will start adding more information about my macro to this answer.
"... to extract email attachments starting from date which I enter in dialog box (I want to extract email attachments just for emails which I received in last seven day not the whole folder)."
Option Explicit
Sub Extract_attachments_recent_emails()
' code for Excel
Dim olApp As Object
Dim olMail As Object
Dim olItems As Object
Dim olfolder As Object
Dim J As Long
Dim strFolder As String
Dim ageDays As Long
Dim strFilter As String
Dim resItems As Object
Set olApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set olApp = CreateObject("Outlook.Application")
End If
strFolder = ThisWorkbook.Path & "\Extract"
Set Olfolder = olApp.GetNamespace("MAPI").Folders("MyEmailAddress").Folders("Inbox")
Set olItems = olfolder.items
' save time with hardcoded number
'ageDays = 7
' be flexible with InputBox
ageDays = InputBox("ageDays", "Input age of oldest mail in days", "7")
strFilter = "[ReceivedTime]>'" & Format(Date - ageDays, "DDDDD HH:NN") & "'"
Set resItems = olItems.Restrict(strFilter)
For Each olMail In resItems
If olMail.Attachments.Count > 0 Then
For J = 1 To olMail.Attachments.Count
OlMail.Attachments.Item(J).SaveAsFile strFolder & "\" & OlMail.Attachments.Item(J).Filename
Next J
End If
Set olMail = Nothing
Next
MsgBox ("Done")
End Sub
What I have, is a similar piece of code & i made it work with the outlook editor (hard enough) and I am trying to get it to now work with Word acting as the outlook editor. (Users are used to word mail) I tried: To move the code directly into word under this document and it did nothing. To follow code i saw on: creating an objword objdoc and then pairing it with the outlook class type of deal, with no luck. Here is a sample of code:
Sub SetCategory()
Dim olMessage As Outlook.MailItem
Set olMessage = Application.ActiveInspector.CurrentItem
If olMessage.SenderName = donations Then
olMessage.Categories = "donations"
ElseIf olMessage.SenderName = "Donations" Then
olMessage.Categories = "donations"
End If
With olMessage
.Send
End With
End Sub
When using "word mail" you are not using Outlook. This describes how to invoke Outlook from Word. Once Outlook is open you can use Outlook VBA.
http://www.howto-outlook.com/howto/senddocasmail.htm
Untested, and you will have to remove the parts you do not need.
Sub SendDocAsMail()
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
On Error Resume Next
'Start Outlook if it isn't running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0 ' <=== Important to see errors now if there are any
'Create a new message
Set oItem = oOutlookApp.CreateItem(olMailItem)
' --------------------------
'Set oItem = oOutlookApp.ActiveInspector.CurrentItem
If oItem.SenderName = donations Then
oItem.Categories = "donations"
ElseIf oItem.SenderName = "Donations" Then
oItem.Categories = "donations"
End If
' --------------------------
'Allow the user to write a short intro and put it at the top of the body
Dim msgIntro As String
msgIntro = InputBox("Write a short intro to put above your default " & _
"signature and current document." & vbCrLf & vbCrLf & _
"Press Cancel to create the mail without intro and " & _
"signature.", "Intro")
'Copy the open document
Selection.WholeStory
Selection.Copy
Selection.End = True
'Set the WordEditor
Dim objInsp As Outlook.Inspector
Dim wdEditor As Word.Document
Set objInsp = oItem.GetInspector
Set wdEditor = objInsp.WordEditor
'Write the intro if specified
Dim i As Integer
If msgIntro = IsNothing Then
i = 1
'Comment the next line to leave your default signature below the document
wdEditor.Content.Delete
Else
'Write the intro above the signature
wdEditor.Characters(1).InsertBefore (msgIntro)
i = wdEditor.Characters.Count
wdEditor.Characters(i).InlineShapes.AddHorizontalLineStandard
wdEditor.Characters(i + 1).InsertParagraph
i = i + 2
End If
'Place the current document under the intro and signature
wdEditor.Characters(i).PasteAndFormat (wdFormatOriginalFormatting)
'Display the message
oItem.Display
'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set objInsp = Nothing
Set wdEditor = Nothing
End Sub
Edit: Added, based on comment. This is a step that beginners trip on.
"Since this macro also uses Outlook functionality to create the mail we must add the reference to the project. To do this choose Tools-> References… and select Microsoft Outlook 12.0 Object Library (or 14.0 when using Outlook 2010). After this press OK."
Latest Outlook versions use Word as an email editor by default. There is no need to check out the editor type. The WordEditor property of the Inspector class returns the Microsoft Word Document Object Model of the message being displayed. You can read more about that in the Chapter 17: Working with Item Bodies .
Also you may find the How to automate Outlook and Word by using Visual C# .NET to create a pre-populated e-mail message that can be edited article helpful.