Excel VBA - Outlook Email into Excel - excel

I've done a fair bit of searching but everything I've come up with is doing the opposite of what I'm trying to do.
I have a whole bunch of automatically generated emails that I get, and I want to translate them down into excel. Everything works, except that it dumps it exclusively into one cell. I would like this to have multiple rows of the email come through as multiple lines in excel.
For example, email body is this. This will have a variable number of rows, so I can't really just use Mid functions.
Hello,
Job AAA completed successfully.
ThingA1 = good
ThingA2 = error code 5
This entire string shows up under cell A2 (which, is kinda what I told it to do...but I have no idea how to tell it to put it as multiple IDs). I want it to show up as different cells (covering cells A2:A6 in this instance).
Sub ParseAllEmails()
'loop through the outlook inbox, find stuff with errors, parse/paste it in
Dim OutApp As Outlook.Application, OLF As Outlook.MAPIFolder, OutMail As Outlook.MailItem
Dim myReport As Boolean, zeroErrors As Boolean
Dim parseSht As Worksheet
Dim i As Long
'establish connection
Set OutApp = CreateObject("Outlook.Application")
Set OLF = OutApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set parseSht = ThisWorkbook.Sheets("parse")
'go through inbox looking for scheduler emails
For i = OLF.Items.Count To 1 Step -1
If TypeOf OLF.Items(i) Is MailItem Then
Set OutMail = OLF.Items(i)
myReport = (LCase(Left(OutMail.Subject, 3)) = "job")
zeroErrors = (InStr(1, LCase(OutMail.Subject), "errors=0") > 0)
If myReport And Not zeroErrors Then
parseSht.Range("A2:A500").Value = Trim(OutMail.Body)
Exit Sub
End If
End If
Next
End Sub

First of all, I'd suggest replacing the following part where the code iterates over all items in the Inbox folder:
'go through inbox looking for scheduler emails
For i = OLF.Items.Count To 1 Step -1
If TypeOf OLF.Items(i) Is MailItem Then
Set OutMail = OLF.Items(i)
myReport = (LCase(Left(OutMail.Subject, 3)) = "job")
zeroErrors = (InStr(1, LCase(OutMail.Subject), "errors=0") > 0)
If myReport And Not zeroErrors Then
Use the Find/FindNext or Restrict methods of the Items class which allow getting items that correspond to your conditions only. All you need is to iterate over the result collection and process such items after. Read more about these methods in the following articles:
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
To break the single message body string into separate lines you could use the Slit function available in VBA:
Dim strings() As String
strings = Split(mailItem.Body, vbNewLine)
So, you can detect the data which is required to be pasted and process these lines in the loop by adding each entry into a separate cell (if required).

Related

Excel VBA Outlook16 cannot read MailItem .Body property, though Outlook14 can

I have taken on a spreadsheet that has a VBA routine to read outlook emails
It works fine for me on Excel2010 (using the Outlook Office14.0 Object library) but now doesnt work for my colleague who's on Excel2016 (he's referenced the Outlook Office16.0 Object library in the VBA references), here's the key bits of code:
Dim olItms As Outlook.Items, Dim olMail As Variant,
For Each olMail In olItms
mailContents() = Split(olMail.Body, Chr(13))
I can add a Watch and see all of the emails in the chosen folder are in the olItms array
I can view the properties for each olMail object, eg sender & time received, all look fine.
In my Excel2010 I can read the .Body property and write it to Excel etc
In his Excel2016 I can similarly add a Watch and see all of the emails
I can similarly view the properties for each olMail object
However I cannot read the .Body property, it shows as <> instead of the text and nothing is read
In his Excel2016 session I can use the VBA to open/activate the email
I can also write to the .Body property in the VBA, eg olMail.Body = "test text" works, replacing the body of text in the open/activate email with "test text"
However I still can't read the body text.
The other similar fields (HTMLBody, RTFBody) similarly show as <> with no text read
I can't see anything in his Outlook properties that could be restricting it
The emails definitely have body text in them, as they get read ok in my Excel2010
The Outlook16 object libary must be working ok as the other email properties are reading ok (unless it could be partly working ?)
Here's a copy of all the code up to the error point (with some names changed)
Sub GetIncomeUpdatesFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olMailbox As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant, vRow As Variant
Dim i As Long
Dim FolderAddress As String, arrFolders() As String, mailContents() As String
Dim EarliestDate As Date
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
On Error Resume Next
Set olMailbox = olNs.Folders("mailbox#company.com").Folders("Inbox")
'Produces the relevant folder as a string
If Range("FolderAddress") = "Update" Or Range("FolderAddress") = "Create" Then
FolderAddress = "\\mailbox#company.com\*Folders\Data\xxx\"
Else
FolderAddress = "\\mailbox#company.com\*Folders\Data\xxx\Update\"
End If
FolderAddress = FolderAddress + Range("FolderAddress")
'changes Folder address into an array
arrFolders() = Split(FolderAddress, "\")
'Enters first part of fodler address
Set olFldr = olNs.Folders.Item(arrFolders(2))
'Navigates to relevant folder
If Not olFldr Is Nothing Then
For i = 3 To UBound(arrFolders)
Set colFolders = olFldr.Folders
Set olFldr = Nothing
Set olFldr = colFolders.Item(arrFolders(i))
If olFldr Is Nothing Then
Exit For
End If
Next
End If
Application.DisplayStatusBar = True
Set olItms = olFldr.Items
'Sorts emails by date received
olItms.Sort “Received”
i = 1
UserForm1.TextBox1 = Format(CDate(Evaluate("WORKDAY(TODAY(),-1)")), "dd/mm/yyyy")
UserForm1.TextBox2 = Format(CDate(Evaluate("WORKDAY(TODAY(),-0)")), "dd/mm/yyyy")
UserForm1.Show
EarliestDate = UserForm1.TextBox1
LatestDate = UserForm1.TextBox2
'moves through mails one by one for all emails received after specified earliest date"
iColumn = 3
For Each olMail In olItms
If LatestDate > CDate(olMail.ReceivedTime) Then
If CDate(olMail.ReceivedTime) > EarliestDate Then
'Splits content of the mail into an array with each element of the array one line in the original email
mailContents() = Split(olMail.Body, Chr(13))
Try to use the GetInspector or Display method before getting the message body.
Another point is a security trigger in the Outlook object model. Outlook may restrict access to secure properties when you automate the host from another process. You may try to run the same code from a COM add-in where you deal with a safe Application instance which doesn't trigger a security issue. There are several ways for suppressing such issues when dealing with OOM:
Use a third-party components for suppressing Outlook security warnings/issues. See Security Manager for Microsoft Outlook for more information.
Use a low-level API instead of OOM. Or any other third-party wrappers around that API, for example, Redemption.
Develop a COM add-in which has access to the trusted Application object. And then communicate from a standalone application with an add-in using standard .Net tools (Remoting).
Use group policy objects for setting up machines.
Install any AV software with the latest databases (up to date).
There are other aspects in the code listed above. Let's cover them in depth.
Instead of using the following code:
Set olMailbox = olNs.Folders("mailbox#company.com").Folders("Inbox")
You need to use the GetDefaultFolder method of the Namespace or Store class which is similar to the GetDefaultFolder method of the NameSpace object. The difference is that this method gets the default folder on the delivery store that is associated with the account, whereas NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile.
Iterating over all items in the folder is not really a good idea:
For Each olMail In olItms
If LatestDate > CDate(olMail.ReceivedTime) Then
If CDate(olMail.ReceivedTime) > EarliestDate Then
Use the Find/FindNext or Restrict methods of the Items class instead. Read more about these methods in the following articles:
How To: Retrieve Outlook calendar items using Find and FindNext methods
How To: Use Restrict method in Outlook to get calendar items

Looping through Arrays with VBA, to Move outlook emails from one folder to another?

I want to move emails of invoices from a main folder to a different folder.
I extracted the subject of the emails with VBA from outlook in the first module, they are in column 3. Then I manually write out the folder I would like the emails to move to, in column 8. (The names of the folder is a subfolder)
Column 3 is the subject of the email which I extracted, I used the restrict method for outlook to return the email with the specific tittle
Column 8 is the folder I would like the email to move too.
Example is like below
The code has to place email in the main folder with subject'A' to Folder '1'
Column 3 columnn 8
A 1
B 2
C 2
D 1
E 1
The reason I use arrays is because, every time I make an extract, the list changes, hence it is dynamic. Therefore, I used LBound and UBound to include the whole list of invoices.
I have declared all variables here in the first module as 'public'. Only left the relevant ones here to the code
Sub MovingEmails_Invoices()
'Declare your Variables
Dim i As Object
Dim myitems As Object
Dim subfolder As Outlook.Folder
'Set Outlook Inbox Reference
Set OP = New Outlook.Application
Set NS = OP.GetNamespace("MAPI")
'To loop through subfolder and its folders
Set rootfol = NS.Folders("SYNTHES-JNJCZ-GBS.DE.AT.CH#ITS.JNJ.com")
Set Folder = rootfol.Folders("Austria")
'The list for invoice numbers and folders is dynamic
'Each subject being searched is different
Dim Listmails() As Variant
Dim Rowcount As Long
Dim Mailsubject As Variant
Dim FolderName As Variant
Dim MS As String
Dim myrestrictitem As Outlook.items
'Establish the array based on the mailbox extract
Sheets("files").Activate
Listmails = Range("A2").CurrentRegion
'Ititerate through the array which is dynamic (One-dimensional)
For Rowcount = LBound(Listmails) To UBound(Listmails)
'3rd row for email subject 'used DASL Filter
Mailsubject = Application.WorksheetFunction.Index(Listmails, Rowcount, 3)
MS = "urn:schemas:mailheader:subject LIKE \'%" & Mailsubject & "%\'"
'Find the email based on the array for email subject
Set myitems = Folder.items
Set myrestrictitem = myitems.Restrict(MS)
For each i in myrestrictitem
If i.class = olmail then
'8th row for folder name
FolderName = Application.WorksheetFunction.Index(Listmails, Rowcount,8)
Set subfolder = rootfol.Folders(FolderName) ' i have an error here
'If email found then mark it as read
i.UnRead = False
'Move it to the subfolder based on the array for folder name
i.Move subfolder
Next Rowcount
End Sub
Now, I used the example I got from Microsoft Office Center to construct the restrict part, the last example on this page: https://learn.microsoft.com/en-us/office/vba/api/outlook.items.restrict
when I try to do the same way, it doesn't work for my code.
The error message comes from;
Set myrestrictitem = myitems.Restrict(MS)
and
?
Set subfolder = rootfol.Folders(FolderName)
The error message is the condition is not correct. Also it could be because I am doing the loop incorrectly.
Could there be another way of doing this, without arrays maybe? do i need IF condition?
You condition must include the #SQL= prefix. It is also a good idea to double quote the DASL property names:
#SQL="urn:schemas:mailheader:subject" LIKE '%test%'
You also should not use "for each" when you are changing the collection (by calling Move). Use a down loop:
for i = myrestrictitem.Count to 1 step -1
set item = myrestrictitem.Item(i)
..
item.Move subfolder

Create draft emails and save in folder other than the default Drafts folder

I have written code that pulls information from an Excel table to an Outlook template.
I would like two more things.
Instead of saving the emails in "Draft" I would like to make a new folder called "Reclass" and save the unsent emails there.
Using a If statement (I think) so only the users (this is a section in my Excel table that I am pulling from for the MailTo part of my email) that have Y in their row (Reclass column in the table has either Y or N in it) will get a email drafted to be sent on a later date.
Public Enum EmailColumns
ecEmailAdresses = 44
ecSubject = 43
End Enum
Public Sub SaveEmails()
Dim r As Long
'The With Statement allows the user to "Perform a series of statements on a specified object without specifying the name of the object multiple times"
'.Cells(.Row.Count, ecEmailAdresses).End(xlUp).Row actually refers to ThisWorkbook.Worksheets("Data insert").Cells(.Rows.Count, ecEmailAdresses).End(xlUp).Row
With ThisWorkbook.Worksheets("Report")
'.Cells(): references a cell or range of cells on Worksheets("Data insert")
'.Cells(.Rows.Count, ecEmailAdresses): References the last cell in column 43 of the worsheet
'.End(xlUp): Changes the reference from the last cell to the first used cell above the last cell in column 44
'.Cells(.Rows.Count, ecEmailAdressess).End(xlUp).Row: returns the Row number of the last cell column 44
For r = 2 To .Cells(.Rows.Count, ecEmailAdresses).End(xlUp).Row
getPOAccrualTemplate(MailTo:=.Cells(r, ecEmailAdresses), Subject:=.Cells(r, ecSubject)).Save
Next
End With
End Sub
Public Function getPOAccrualTemplate(MailTo As String, Optional CC As String, Optional BC As String, Optional Subject As String) As Object
Const TEMPLATE_PATH As String = "C:\Users\JoeDoe\Documents\Project\Email Template.oft"
Dim OutApp As Object, OutMail As Object
'CreateObject("Outlook.Application"): Creates an instance of an Outlook Application.
'Outlook.Application.CreatItemFromTemplate returns a new MailItem Based on a saved email Template
Set OutMail = CreateObject("Outlook.Application").CreateItemFromTemplate(TEMPLATE_PATH)
With OutMail
.To = MailTo
.CC = CC
.BCC = BC
.Subject = Subject
End With
'Returns the new MailItem to the caller of the function
Set getTemplate = OutMail
End Function
Instead of using Application.CreateItemFromTemplate, use MAPIFolder.Items.Add, where MAPIFolder is a folder retrieved from OOM. Assuming that folder is on the same level as the Drafts folder, try something like the following:
set app = CreateObject("Outlook.Application")
set ns = app.GetNamespace("MAPI")
ns.Logon
set drafts = ns.GetDefaultFolder(olFolderDrafts)
on error resume next 'the line below can raise an exception if the folder is not found
set myFolder = drafts.Parent.Folders("Reclass")
if myFolder Is Nothing Then
set myFolder = drafts.Parent.Folders.Add("Reclass")
end If
set OutMail = myFolder.Items.Add

outlook "To Do" items into Excel using VBA

First off, I'm new to VBA, with about 20 hours of training.
I'm trying to export items from Outlook 2010 to Excel 2010. I want to grab all the unfinished "To Do" items from Outlook and throw them into Excel with one item per row, and columns for item parameters (like Subject, Due Date, attachments, etc.).
Here's the first pass that actually does what I explained, and imports only tasks (tasks are a subset of all to do items, from what I understand) and their Subject/Due Date:
Function GetOutlookApp() As Object
On Error Resume Next
Set GetOutlookApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set GetOutlookApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
End Function
Sub getOlTasks()
Dim olApp As Object ' Outlook.Application
Dim olnameSpace As Object ' Outlook.Namespace
Dim taskFolder As Object ' Outlook.MAPIFolder
Dim tasks As Object ' Outlook.Items
Dim tsk As Object
Set olApp = GetOutlookApp
Set olnameSpace = olApp.GetNamespace("MAPI")
Set taskFolder = olnameSpace.GetDefaultFolder(13) 'olFolderTasks is folder# 13, apparently
Set tasks = taskFolder.Items
For x = 1 To tasks.Count
Set tsk = tasks.Item(x)
Sheet1.Cells(1, 1).Activate
Do While IsEmpty(ActiveCell) = False
Selection.Offset(1, 0).Activate
Loop
'Fill in Data
If Not tsk.Complete Then
ActiveCell.Value = tsk.Subject
Selection.Offset(0, 1).Activate
ActiveCell.Value = tsk.DueDate
Selection.Offset(1, -1).Activate
End If
Next x
End Sub
I tried to do this with only "tasks" items, everything was going smoothly until I realized that tasks can't have attachments. When I have an email w/attachment that I turn into a task, I lose the attachment. Apparently what I need to do is import all "To Do items", rather than just tasks.
So My questions are:
1) What folder number is olFolderToDo? I have seen people run code like:
Set taskFolder = olnameSpace.GetDefaultFolder(olFolderTasks) 'rather than GetDefaultFolder(13)
which would lead me to believe I should be able to just use olFolderToDo, but when I try to use the name of the folder in my first example rather than the number, I get an invalid argument runtime error. If anyone knows why, I'd be interested to know.
2) How would I go about importing an attachment from an email to a specific cell in excel?
See OlDefaultFolders Enumeration (Outlook)
Name Value Description
olFolderToDo 28 The To Do folder.

Copy email to the clipboard with Outlook VBA

How do I copy an email to the clipboard and then paste it into excel with the tables intact?
I am using Outlook 2007 and I want to do the equivalent of
"Click on email > Select All > Copy > Switch to Excel > Select Cell > Paste".
I have the Excel Object Model pretty well figured out, but have no experience in Outlook other than the following code.
Dim mapi As NameSpace
Dim msg As Outlook.MailItem
Set mapi = Outlook.Application.GetNamespace("MAPI")
Set msg = mapi.Folders.Item(1).Folders.Item("Posteingang").Folders.Item(1).Folders.Item(7).Items.Item(526)
I must admit I use this in Outlook 2003, but please see if it works in 2007 as well:
you can use the MSForms.DataObject to exchange data with the clipboard. In Outlook VBA, create a reference to "Microsoft Forms 2.0 Object Library", and try this code (you can of course attach the Sub() to a button, etc.):
Sub Test()
Dim M As MailItem, Buf As MSForms.DataObject
Set M = ActiveExplorer().Selection.Item(1)
Set Buf = New MSForms.DataObject
Buf.SetText M.HTMLBody
Buf.PutInClipboard
End Sub
After that, switch to Excel and press Ctrl-V - there we go!
If you also want to find the currently running Excel Application and automate even this, let me know.
There's always a valid HTMLBody, even when the mail was sent in Plain Text or RTF, and Excel will display all text attributes conveyed within HTMLBody incl. columns, colors, fonts, hyperlinks, indents etc. However, embedded images are not copied.
This code demonstrates the essentials, but doesn't check if really a MailItem is selected. This would require more coding, if you want to make it work for calendar entries, contacts, etc. as well.
It's enough if you have selected the mail in the list view, you don't even need to open it.
I finally picked it up again and completely automated it. Here are the basics of what I did to automate it.
Dim appExcel As Excel.Application
Dim Buf As MSForms.DataObject
Dim Shape As Excel.Shape
Dim mitm As MailItem
Dim itm As Object
Dim rws As Excel.Worksheet
'code to open excel
Set appExcel = VBA.GetObject(, "Excel.Application")
'...
'code to loop through emails here
Set mitm = itm
body = Replace(mitm.HTMLBody, "http://example.com/images/logo.jpg", "")
Call Buf.SetText(body)
Call Buf.PutInClipboard
Call rws.Cells(i, 1).PasteSpecial
For Each Shape In rws.Shapes
Shape.Delete 'this deletes the empty shapes
Next Shape
'next itm
I removed the logo urls to save time, and when you're dealing with 300 emails, that translates into at least ten minutes saved.
I got the code I needed from a TechRepublic article, and then changed it to suit my needs. Many thanks to the accepted answerer of this question for the clipboard code.
Ok so I will have to make certain assumptions because there is information missing from your question.
Firstly you didn't say what mailformat the message is... HTML would be the easiest, the process will be different for RTF and not possible in plaintext
Since you are refering to tables I will assume they are HTML tables and the mail format is HTML.
Also it is not clear from your question if you want the table content pasted seperately (1 excel cell per table cell) and the rest of the emails bodytext pasted into 1 cell or several?
finally you haven't really said if you want the VBA running from Outlook or Excel (not that important but it affects which intrinsic objects are available.
Anyway code sample:
Outlook code to access the htmlbody prop
Dim mapi As Namespace
Set mapi = Application.Session
Dim msg As MailItem
Set msg = mapi.Folders.Item(1).Folders.Item("Posteingang").Folders.Item(1).Folders.Item(7).Items.Item(526)
Dim strHTML as String
strHTML = msg.HTMLBody
' There is no object model collection for html tables within the htmlbody (which is a string of html) you will need to parse the html and collect the tables before inserting into Excel.
After a while again, I found another way. MailItem.Body is plain text, and has a tab character between table cells. So I used that. Here is the gist of what I did:
Sub Import()
Dim itms As Outlook.Items
Dim itm As Object
Dim i As Long, j As Long
Dim body As String
Dim mitm As Outlook.MailItem
For Each itm In itms
Set mitm = itm
ParseReports (mitm.body) 'uses the global var k
Next itm
End Sub
Sub ParseReports(text As String)
Dim table(1 To 1000, 1 To 11) As String 'I'm not expecting to see a thousand rows!
Dim drow(1 To 11) As String
For Each Row In VBA.Split(text, vbCrLf)
j = 1
For Each Col In VBA.Split(Row, vbTab)
table(i, j) = Col
j = j + 1
Next Col
i = i + 1
Next Row
For i = 1 To l
For j = 1 To 11
drow(j) = table(i, j)
Next j
hws.Range(hws.Cells(k, 1), hws.Cells(k, 11)) = drow
k = k + 1
Next i
End Sub
Average: 77 emails processed per second. I do some minor processing and extracting.

Resources