P130600439 100356 ACTI149 202 43.32
He found a code sample online that uses InStr and Split to locate the Outlook data and send it to the workbook, but he needed help making it work with his line of text.
In this code sample, I'm using late binding to set the Excel and RegEx objects instead of using early binding and selecting these two object libraries in VB Editor Tools, References menu. Generally speaking, using early binding is faster but it won't matter in this simple code. The code sample at copy-to-excel-regex.txt uses early binding. Late binding makes it easier to share macros as the references do not need to be set.
Read more about RegEx at Use RegEx to extract text from an Outlook email message
To use this code, add it to the VB Editor then create a Run a Script Rule.
To test the code on existing messages, replace
Sub CopyToExcel(olItem As Outlook.MailItem)
with
Sub CopyToExcel()
Dim olItem As Outlook.MailItem
and add
Set olItem = Application.ActiveExplorer().Selection(1)
after Set xlSheet = xlWB.Sheets("Sheet1")
CopyToExcel code sample
Option Explicit
Private Const xlUp As Long = -4162
Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\test.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*([\d-\.]*))"
End With
If Reg1.test(sText) Then
' each "(\w*)" and the "(\d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
vText3 = Trim(M.SubMatches(3))
vText4 = Trim(M.SubMatches(4))
vText5 = Trim(M.SubMatches(5))
Next
End If
xlSheet.Range("B" & rCount) = vText
xlSheet.Range("c" & rCount) = vText2
xlSheet.Range("d" & rCount) = vText3
xlSheet.Range("e" & rCount) = vText4
xlSheet.Range("f" & rCount) = vText5
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Customize the code
If you need to throw the entire line into one cell, you'll use the following code snippet. You could use a shorter pattern. (In my testing, the line wrapped in the cell automatically using the shorter pattern.)
.Pattern = "((P130[\w*-\s*]*[\d-\.]*))"
With Reg1
' the entire string in one variable
.Pattern = "((P130\w*\s*\w*\s*\w*\s*\w*\s*[\d-\.]*))"
End With
If Reg1.test(sText) Then
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
Next
End If
xlSheet.Range("B" & rCount) = vText
xlWB.Close 1
Run the macro on all messages in the folder
This macro looks for the pattern in each message in the folder and writes the found values, subject, and received time to the Excel sheet.
This macro was created by merging the macro above with the macro at "Outlook VBA: Work with Open Item or Selected Item".
To use, select a mail folder in Outlook then run the macro.
Option Explicit
Private Const xlUp As Long = -4162
Sub CopyAllMessagesToExcel()
Dim objOL As Outlook.Application
Dim objItems As Outlook.Items
Dim objFolder As Outlook.MAPIFolder
Dim olItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\test.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
For Each olItem In objItems
On Error Resume Next
With olItem
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "(Volume\s*(\d*)\s*Issue\s*(\d*))"
End With
If Reg1.Test(sText) Then
' each "(\w*)" and the "(\d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
Next
xlSheet.Range("B" & rCount) = vText
xlSheet.Range("c" & rCount) = vText2
xlSheet.Range("d" & rCount) = .Subject
xlSheet.Range("e" & rCount) = .ReceivedTime
'xlSheet.Range("f" & rCount) = vText5
' next line
rCount = rCount + 1
End If
' do whatever
Debug.Print .Subject
End With
Next
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objOL = Nothing
End Sub
How to use this macro
First: You will need macro security set to low during testing.
Check your macro security in Outlook 2010 or 2013, at File, Options, Trust Center and then open Trust Center Settings. Change the Macro Settings to low for testing. In Outlook 2007 and older, it’s at Tools, Macro Security.
After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To put the code in a module:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor
More Information
- Autoaccept a Meeting Request using Rules
- Automatically Add a Category to Accepted Meetings
- Blocking Mail From New Top-Level Domains
- Convert RTF Messages to Plain Text Format
- Create a rule to delete mail after a number of days
- Create a Task from an Email using a Rule
- Create an Outlook Appointment from a Message
- Create Appointment From Email Automatically
- Delegates, Meeting Requests, and Rules
- Delete attachments from messages
- Forward meeting details to another address
- How to Change the Font used for Outlook's RSS Feeds
- How to Process Mail After Business Hours
- Keep Canceled Meetings on Outlook's Calendar
- Macro to Print Outlook email attachments as they arrive
- Move messages CC'd to an address
- Open All Hyperlinks in an Outlook Email Message
- Outlook AutoReplies: One Script, Many Responses
- Outlook's Rules and Alerts: Run a Script
- Process messages received on a day of the week
- Read Outlook Messages using Plain Text
- Receive a Reminder When a Message Doesn't Arrive?
- Run a script rule: Autoreply using a template
- Run a script rule: Reply to a message
- Run a Script Rule: Send a New Message when a Message Arrives
- Run Rules Now using a Macro
- Run-a-Script Rules Missing in Outlook
- Save all incoming messages to the hard drive
- Save and Rename Outlook Email Attachments
- Save Attachments to the Hard Drive
- Save Outlook Email as a PDF
- Sort messages by Sender domain
- Talking Reminders
- To create a rule with wildcards
- Use a Macro to Copy Data in an Email to Excel
- Use a Rule to delete older messages as new ones arrive
- Use a run a script rule to mark messages read
- Use VBA to move messages with attachments
Ben C says
Hi Diane,
Would there be a way to copy the received date/time of a selected e-mail and then paste it to the clipboard in this format:
"YYYYMMDD_HHMMSS"
Many thanks,
Ben
Diane Poremsky says
You could use a macro to copy it and chose the format.
format(item.receivedtime, "YYYYMMDD_HHMMSS")
A code sample to copy to clipboard is here -
https://www.slipstick.com/developer/code-samples/paste-clipboard-contents-vba/
Coen Elzer says
Hi Diane, thank you for letting us enjoy your expertise. Makes my life a lot easier.
I would like to use this script in a modified version on . I run into a challenge (for me
although :-)) that the information which I would also like to write in the same
sheet is not available in the MailItem object, but in AppointmeI.item. My
knowledge about VB is just not sufficient to know how to approach this in the
correct way.
I managed to receive the data I needed form Appointmentitem, although not in combination the MailItem data. The data which I need: 'appointmentItem.RequiredAttendees'
and '...Start' etc. is returned in a delimited string which I would like to
split up vertically in a column within the same script.
For each of the required attendees I need data from the Alias field which apparently is
available within the MailItem object/ Exchange Global Address List. How to I
let the script look up this data for each required attendee in the GAL and
write it in the row in the active Excel sheet in which the required attendee is
also written down after the split?
Could you help me with this? Is there an easier way to do this?
Milad says
Hi Diane. Thanks for your comprehensive code and following explanations.
I used the code but I ran into a problem: I tried to comment out the "On Error Resume Next" and "On Error GoTo 0" parts of the code to identify the problem and it gave me "Run-Time Error 429 - ActiveX Component can't create object" on the following part of your code:
"Set xlApp = GetObject(, "Excel.Application")"
Can you suggest any help or explanation?
Thanks in Advance
ETL says
Hi Diane, thanks for the easy-to-follow code & comments! It really helps amateur programmers learn. Perhaps you or someone else can help me tweak this: I frequently receive emails containing lists of ISBN numbers, so I'd like to be able to run a macro on selected emails, have it find ALL ISBNs in the body, and compile them in an Excel sheet (ignoring duplicate ISBNs within a given email, but allowing duplicates between emails). As I understand it, my tasks for tweaking this code are:
1) Isolate ISBNs with RegExp (shouldn't be too hard, it's just a 13-digit numerical string)
2) Fetch all strings in an email that match the expression (QUESTION!!! Does this macro already do this? I really can't tell)
3) Check the set of strings for duplicates.
Does that sound about right?
Thanks for your help!
Diane Poremsky says
the macro on this page should work - just remove all of the lines that write to excel, keeping only thing one:
xlSheet.Range("B" & rCount) = vText - where vText will be the isbn - actually, you'll probably want to get all the isbns in a comma (or new list) seperated list and write the string to excel.
the more difficult problem is duplicates but I;m sure there are some excel functions for that. a quickie google found this:
https://stackoverflow.com/questions/32127581/removing-duplicate-values-from-a-string-in-visual-basic
ETL says
Thank you! To avoid duplicates, I modified the RegExp to
([0-9]{13})(?![\s\S]*\1), which should find only one of each particular match. However, I'm not sure if this will throw off the script's loop, and I haven't gotten it finished enough to do a test run yet. As I understand it, the If block in your code loops through each RegExp match to enter them in the Excel. I would rather not put all ISBNs in a single comma-separate list because as each one gets entered in the Excel, I then want to have it run some other functions on the ISBN before finishing the loop and moving onto the next one. (To accomplish this, I am planning to call another macro after the linexlSheet.Range("B" & rCount) = vTextand beforerCount = rCount + 1. Is that the right place to put that?)Thank you again for all your help!
Diane Poremsky says
.global = false after the .pattern will stop it after the first match, but that won't work if there is more than one code in an email.
My thought was to make the comma separated list, then you can remove dupes from it before entering it into Excel, one isbn per row.
ETL says
Thank you Diane. You're absolutely right that my original method was too complicated. I've successfully made the script fetch the ISBNs from selected emails, however I'm running into a couple issues from there:
1) After running the macro, the excel sheet remains blank! It seems like
xlSheet.Range("E" & rCount) = vtextis not working for some reason - or possibly it's not saving the excel file when finished?2) To pull the other info I'm going to need for each ISBN (e.g. title, publisher), I decided to call a user-define function rather than another macro, based off this code, but when I step through the macro with F8, it gets to
http.Open "GET", url, Falseand then it exits the function. I have no experience with webscraping; do you have any idea why that might be happening?3) Lastly, when I run this macro with a blank excel file, for "Find the next empty line of the worksheet," rCount is 2, when it seems like it should be 1. Why is that?
Here's the pastebin for the full macro; if you have a few minutes to look it over I would be eternally grateful!!
chithra says
HI Diane,
I need some automation for exporting data from the excel which is attached in the mail to the new excel file on my machine with some naming convention.
Usyally gets 100's of mail daily where I need to extract the data from each excel and then copy it to the template on my system.
Can you please suggest a solution for this.
Showrya Krovvidi says
Hi Diane, Thanks for all your commendable work with respect to VBscript.
I have been searching for a solution since the past two weeks for one of my critical projects. We have configured emails to be triggered for multiple instances and we receive approximately 1000 emails alerts a day stating the configured URLs are down. Most of them are false positives and it has become a tedious job for me to check all the urls manually. I am a novice in writing macros, but I have tried multiple ways for my problem and no luck.
I need a macro that will open the first url from all the selected emails in an excel and then checks for the http status of the same and return the status in the excel. I was able to find few solutions to check the http status automatically, but getting all the first urls from a set of emails is the toughest part where I have been stuck since the past 2 weeks. Could you please let me know if this can be ever achieved through a macro. If yes, how?
Thanks in advance.
Diane Poremsky says
you would use something like the macro on this page - to get the status. The last macro there shows how to get the page name. Status would be similar.
https://www.slipstick.com/developer/code-samples/open-hyperlinks-email-message/
Shmuel says
Diane,
I am trying to extract all the content of the email. Currently it is opening and saving the Excel, but it is not doing anything with the data.
I am very new to Macros in general, would appreciate any help.
Thank you!
Ian says
Hello Diane
Enjoyed reading the above article I am a novice and I found quite easy to follow, I am looking for some code to do something slightly different, I have 2 mailbox's in my outlook my own and a shared inbox. The shared mailbox is the data i'm looking to extracted from ideally I am looking for a macro to run so I can get the below information from the email into a excel sheet
Email Receipt
Email Subject
Date of Email
Sender of email
Body of Email
The code I have been trying to use and change to my requirement is below
Sub getDataFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim Outlookmail As Variant
Dim i As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("inbox")
i = 1
For Each Outlookmail In Folder.items
If Outlookmail.ReceivedTime >= Range("email_Receipt_Date").Value Then
Range("email_Subject").Offset(i, 0) = Outlookmail.Subject
Range("email_Subject").Offset(i, 0).Columns.AutoFit
Range("email_Subject").Offset(i, 0).VerticalAlignment = xlTop
Range("email_Date").Offset(i, 0).Value = OultlookMail.ReceivedTime
Range("email_Date").Offset(i, 0).Columns.AutoFit
Range("email_Date").Offset(i, 0).VerticalAlignment = xlTop
Range("email_Sender").Offset(i, 0).Value = Outlookmail.SenderName
Range("email_Sender").Offset(i, 0).Columns.AutoFit
Range("email_Sender").Offset(i, 0).VerticalAlignment = xlTop
Range("email_Body").Offset(i, 0).Value = Outlookmail.Body
Range("email_Body").Offset(i, 0).Columns.AutoFit
Range("email_Body").Offset(i, 0).VerticalAlignment = xlTop
i = i + 1
End If
Next Outlookmail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
Ian
Kumar says
Hi, Diana,
I am trying to do something like the below.
When a mail arrives in outlook with a subject line "(Product) Dispatched Batch #3", I want to extract the 'product' name and Batch number, populate this information into a googlesheet/excel. When more mails arrive, for instance, "(Product) Dispatched Batch #8", I want the field to update to the new batch number (i.e. 8).
Is that possible?
Zachary says
Hello Diane,
I have email from the bank coming to my inbox every day. The main portion of if I need is a table in the middle of the email but I currently only can use it when I paste data to excel and then do "text to columns". I have email starting with 2 paragraphs then this table (which I need) and then another 2 paragraphs. I tried to use Power Query (looks bit ugly). Would you recommend to convert email to text and then paste to excel and then record VBA to do text to columns and more cleanup?
Thanks
Diane Poremsky says
Is the portion you need in an identifiable pattern? If so, you could do it all with a macro. for example, if its always short date, then $ and amount, regex could get it.
Or... if you can select it. you could use a macro to pick up the selection and parse it.
Chris says
Hi, how can extract this sections LKA74Q6G05, 10/11/17, 1:46 PM, 10.00, 254728123457, 111111 from different emails into an excel.
The email comes like this
LKA74Q6G05 Confirmed. on 10/11/17 at 1:46 PM Ksh10.00 received from FName LName 254728123457. Account Number 111111 New Utility balance is Ksh2,320.00
Diane Poremsky says
This has an example of getting multiple values from a message.
https://www.slipstick.com/developer/regex-parse-message-text/#2
The harder part is getting the correct patterns - that is mostly trial and error.
Luis Olivas says
Great code as always, just one thing, i have a column i created my self, any way to include it on the info to copy?
Diane Poremsky says
This is a custom field in Outlook? You need to get the value - the macro at https://www.slipstick.com/tutorial/create-a-custom-field-to-mark-messages/#macro shows how to check for the field and value (and have the dims you need to set):
Set UserProp = obj.UserProperties.Find("MyNotes")
If Not UserProp Is Nothing Then
strCurrent = obj.UserProperties("MyNotes").Value
End If
you'll write strCurrent to the sheet.
Kyle says
I am not pulling any data from the bodies of the emails. I've stepped through it and found no errors. The data I'm trying to parse is in it's respective format below. All I need is the data after the colon and spaces. Any help is appreciated:
PMAC Number: 0000253299
PMAC Type: Intra-Unit Move (Same Unit)
Reason PMAC was created: Employment Change Salaried
Effective Date: 2017-11-01
Actual On Site Date: 2017-10-31
Diane Poremsky says
It sounds like the pattern is not right. Do you need the data lines separate? It would be easiest to use separate patterns, as shown here - https://www.slipstick.com/developer/regex-parse-message-text/#2 but if you got the pattern right, you could do it with one pattern and M.SubMatches().
No idea if this is totally correct as i didn't test it, but it would be something like this, with M.SubMatches(0) through M.SubMatches(4) - but using 4 patterns would be less confusing and easier to troubleshoot
.Pattern = "PMAC Number:\s*(\d*)\s*\r*\w*\s*\r*Reason PMAC was created:\s*(\w*)\s*\r*Effective Date:\s*([\d-]*)\s*\r*Actual On Site Date:\s*([\d-]*)\s*\r*"
Kyle Wright says
I figured it out but didn't end up using the pattern function at all
Jimmy says
Hi Diane, I am having trouble using your macro, the last one. I'm not sure how the macro searches for the pattern in the Macro.
Right now, I want the macro to just populate the cells on my active sheet with the email subject after it has searched the emails title/body of the email.
I also have another macro, that searches the body or the title of the email for any string but just displays each email. I would like to learn how to just paste the emails subject line into excel instead of displaying the email.
Diane Poremsky says
If you want to only write the messages that have certain keywords, you don't use regex, you use Find and Restrict to filter the messages then loop the collection to write the .body and .subject to the spreadsheet.
https://www.slipstick.com/developer/print-list-recurring-dates-vba/ shows how to use find/restrict and loop the result to do something. You'd use something like
For Each itm In ResItems
xlSheet.Range("B" & rCount) = .subject
xlSheet.Range("c" & rCount) = .body
rCount = rCount + 1
Next
Chris says
Hi Diane,
Does your code above extract the message from the email? I'm a VBA beginner and am trying to copy a folder of email messages from Outlook to Excel - each message on a separate spreadsheet of a workbook.
Thanks.
Diane Poremsky says
it does - it would be used in situations such as a web form sends data that needs pulled from the message. if you need the entire body, that is doable too but you wouldn't need regex.
This is from the second macro on the page - it puts the subject and receive time in cells, and the reg ex results
xlSheet.Range("B" & rCount) = vText
xlSheet.Range("c" & rCount) = vText2
xlSheet.Range("d" & rCount) = .Subject
xlSheet.Range("e" & rCount) = .ReceivedTime
'xlSheet.Range("f" & rCount) = vText5
There is a regex example at https://www.slipstick.com/developer/regex-parse-message-text/#2 that shows how to get different values separately, rather than breaking up a single entry as the example on this page does - it's fine if you want a phone number in 3 cells.
Chris says
Thanks, Diane. I just need to copy the entire body of the message into Excel and the date of the email. I receive hundreds of emails everyday, so I wanted to run a macro to go through the emails and copy the text into separate spreadsheets. Do I turn lines on and off in the macros above?
Diane Poremsky says
i think it took out everything you don't need from that macro and uploaded it to save-excel.txt. I didn't test it though.
It should get the subject, received time and body - it will put each message in a row in sheet 1 of the workbook - it uses a specific workbook, but you could change it to use the activeworkbook. Don't forget to add Excel library in tools, references.
shiv says
is there any way to capture telephone/mobile number from outlook email(from received email signature )
Diane Poremsky says
the macro can get it - the biggest problem will be to get the pattern correct so it applies to all formats people use (123.456.7890, 123-456-7890, (123) 456-7890 etc) Identifying the proper type of number (phone, fax, mobile) would be a problem, especially if there is more than one number (use .global = false to get only the first #)
This should work - it won't get the country code though.
.Pattern = "\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{4})"
Andy says
Hi Diane! Thanks for providing such an educational site.
I'm looking to complete a similar process only I receive a daily email with an excel attachment instead of a body. I would like to automatically copy the data in the attachment to a local sheet whenever I receive an email that contains the attachment. I’m curious if you have a tutorial on how to do this? Many thanks.
Diane Poremsky says
i don't have a specific tutorial, but you'd need to open the attachment (i have code samples for that), copy the data (if it's always the same cells, it will be super easy, otherwise you need to find the used cells), then open the other workbook and insert it.
Mike says
So the macro pulls the information from the body of the email and adds it to an excel spreadsheet. Is there a way to alter this code so it pulls the information from an .xls attachment in the email, and only for a specific email folder?
Diane Poremsky says
Specific folder would be easy; pulling together from a spreadsheet would be doable but not necessarily easy. Would the values be in the same cells all the time? That would definitely be easier.
Valle says
I have a problem where I would need to extract data from an XLS email attachment and the value would be in the same cell every time and should exported to another excel file into a specific cell.
Diane Poremsky says
If the data is always in the same cell, its won't be too difficult - I don't have any samples that get data from an attachment - but if you have a macro that works in Excel to do the excel steps, its not hard to convert it to run from outlook on an attachment.
Evan says
I have a slightly harder challenge, I receive one email with a compressed folder with multiple excel spreadsheets, within the excel spreadsheets are multiple tabs. I need to extract one cell from each of the tabs within each of the excel spreadsheets, this could be done daily or weekly depending on need.
Diane Poremsky says
That will definitely be harder since you need to extract the workbooks from the zip then open them. I don't think i have any code that opens zips - but once the files are extracted, get the values from each sheet won't be hard, as long as its always the same sheet & cell.
Umair says
Hi. I have a question about something that I am trying to implement. Is there a way to get the name of an attached file with an email. Put it in the excel sheet and preferably also store the attached file in a specified folder on the hard drive.
I am getting many emails that have attachments(mostly pdf documents) that I would like to automate. Recording them in an excel sheet.
Please let me know if you have any suggestions/solutions.
Diane Poremsky says
Sure, you can get the name. using item.attachments.Item(i).FileName - see https://www.slipstick.com/developer/save-attachments-to-the-hard-drive/ for code samples that get the filename and save the attachment. It would be easy to put the bits you need into this macro - just make sure the object names match if you copy and paste code.
Tarak says
Hi,
Thanks for the help.
I'm working in an IT company and will continuously receive emails from a particular person
regarding so work details.
As copying that content manually will take a lot of time as the number of mails
received will be in thousands I am looking for an option to automate this process.
Can you help me with the code that automatically fetches the body of an email
received from particular sender and save that in an excel.
Thanks.
Diane Poremsky says
The easiest would be a run a script macro and rather than using regex to grab values, you'd send the entire body over. The macro sample at https://www.slipstick.com/developer/code-samples/macro-export-outlook-fields-excel/ does this.
klllmmm says
Is there a way to get email headers into excel or into text file format? Currently i copy paste the eail headers one by one.
Is there a better way? Thanks
Diane Poremsky says
The internet header? Sure - you can get it using VBA, see https://www.slipstick.com/developer/code-samples/outlooks-internet-headers/ - the code doesn't put it into Excel, but working it into a macro that writes to excel wouldn't be all that difficult.
klllmmm says
Thank you very much!
Channing Workman says
Diane,
I am trying to parse an email address in the body of an email.
First Name: Test
Last Name: Tested
Email Address: test@gmail.com
I am able to parse the others without any issue and I've succeeded in getting them copied to the excel file.
However, the Email address isn't coming through. I'm using this RegEx pattern.
.Pattern = "(Email Address[:]([w-s]*)s*)n"
Any thoughts?
Thank you!
Channing
Diane Poremsky says
I'm assuming the website software removed the backslashes from the pattern.
.Pattern = "(Email Address[:]([\w-\s]*)\s*)\n"
i use
- if it's the only @ sign in the body, you won't need the text phrase to qualify it.
Diane Poremsky says
** That is probably not a good example of regex patterns - the [ ] should probably be replaced with ( )
Angelo Pillay says
Good day Diane.
I am not an expert in VBA, in fact just learning by tutorials.
my question is... if i wanted to drag am email from outlook into excel and only record the inform in the subject line.
would that be possible.
example: Subject line reads : Monday's bread, expiring 20/05/2017.
the information should pull through cell A1= Mondays bread
cell B1 expiring 20/05/2017.
I hope that makes sense.
Diane Poremsky says
yes, that is easy to do. Is the subject format always the same format? That will make it easier to create a pattern that works.
.pattern = "(.*), expiring (.*)" could be a basic pattern, then use
vText = Trim(M.SubMatches(0))
vText2 = Trim(M.SubMatches(1))
to pick up the values and pass them to excel.
ShaneS says
Thank you for this code. I am trying capture multiple lines in an email to place into excel. I used your code "CopyToExcel code sample" modified with the Select Case but I am getting an Run-time error of Invalid procedure call or argument. The debug lands on vText = Trim(M.SubMatches(1)) . I think I need to Dim M.SubMatches as ____.
Here is a snip-it of my code.
For i = 1 To 3With Reg1
Select Case i
Case 1
.pattern = "Reporters*([w-s]*)s*n"
.Global = False
Case 2
.pattern = "(Urban Water Supplier/Number s*([w-s]*)s*)n"
.Global = False
Case 3
.pattern = "(Reporting Month s*([w-s]*)s*)n"
.Global = False
End Select
End With
If Reg1.Test(sText) Then
' each "(w*)" and the "(d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
vText3 = Trim(M.SubMatches(3))
vText4 = Trim(M.SubMatches(4))
vText5 = Trim(M.SubMatches(5))
Next
End If
Next
Diane Poremsky says
the 1 in vText = Trim(M.SubMatches(1)) indicates which set of parentheses to use. Its zero based, so 1 = second set of parens. try using 0 instead or add another set of () to the first one. You just need vText = Trim(M.SubMatches(1)) for the variables, catch each value like this:
if i = 1 then strWhatever = vtext
if i = 2 then strSomething = vtext
Levi Michaels says
Hi Diane, I have the same issue and this is the exact solution I need (a way to assign each of my matched groups to a variable). Can you please explain where exactly in the code it should run this part?
if i = 1 then strWhatever = vtext
if i = 2 then strSomething = vtext
Diane Poremsky says
That would go after this line:
vText = Trim(M.SubMatches(1))
Abhay says
Hi Diane,
Thanks for the script and it works perfectly fine . But if I want to read only subject and not even go to email body it doesnt work. I tried keeping only subject line but blank body, I didnt get any data in excel.
Can you help me where I am going wrong ?
Diane Poremsky says
to get the subject (assuming you need to get something from it using regex), use sText = olItem.subject
vijayakumar says
Hi Diane Poremsky,
Thanks for wonderful code. i want code that compare the subject from excel when subject is matched it opens excel attachment from mail ,copy the data and paste it into new sheet.
thnks
vijay
Diane Poremsky says
so you want to check a list in excel and if the message subject matches that list, open the attachment and copy the data into excel? i don;t have any code samples that do that. it will be more efficient if you load the subjects into an array - this way it won't need to keep opening the workbook. Info on arrays here - https://www.slipstick.com/developer/using-arrays-outlook-macros/. The code to copy and paste can be recorded in excel then tweaked to work from outlook.
vijayakumar says
thanks. good logic and works well...
vijayakumar says
Hi Diane
it matches subject and shows mail content well. but i want to open the excel attachment from matched subject then copy the cell values and paste to another excel sheet
Diane Poremsky says
You should be able to do it - but it will be complicated. I don't have any code samples that come close to doing this, unfortunately, so you are on your own. Saving and opening it is not a problem (i have samples for that), getting the subject from a worksheet is not a problem (but will be fastest if you read it into an array when outlook starts up rather than each time a message meeting specific conditions arrives - i have samples that read a text file to build the array, but non that use a workseheet). Once you get it open, copy and pasting cells isn't hard - you just need to properly reference the workbooks.
Sam says
Hello, I pasted the macro into my module, created the excel test file....but nothing gets saved into my excel. The immediate window shows all the info, but nothing gets transferred to excel.
Diane Poremsky says
Add xlWB.Save right before the xlWB.Close line. Also, is the pattern found in the message?
Does it work with these fields:
xlSheet.Range("B" & rCount) = olItem.Subject
xlSheet.Range("c" & rCount) = olItem.SenderName
xlSheet.Range("d" & rCount) = olItem.SenderEmailAddress
xlSheet.Range("e" & rCount) = olItem.BodyFormat
xlSheet.Range("f" & rCount) = vText5
Daniel says
What do i need to add for it recognize $, it will not accepted $150
Diane Poremsky says
Where are you trying to use that? Generally speaking, if you are trying to enter it as 150 dollars, you'd enter 150 and cell formatting would take care of it, but using "$150.00" should work too (with quotes).
Reuben says
Hi Diane,
I received about 2000 emails on outlook, every email body use the sames format, an example is as below
Certificate Date: 29/09/2016
Certificate Number: KRAVWLTO00262073816
PIN of withholder: P000611389V
Name of withholder: PZ CUSSONS
PIN of payee: P051120507D
Name of payee: KIMBERLY
Amount of Tax withheld (Ksh): 2,016
Now , i would like an easier way of exporting the above information to excel.
Regards
Diane Poremsky says
You'd use the method used in the macro at https://www.slipstick.com/developer/regex-parse-message-text/#2 - basically, use the regex part to get the values passed to Excel. something like this (but with 1 case for each entry)
With Reg1
Select Case i
Case 1
.Pattern = "(Certificate Date[:]([\d/]*)\s*)\n"
.Global = False
Case 2
.Pattern = "(Certificate Number[:]([\w\d]*)\s*)\n"
.Global = False
Case 3
.Pattern = "(Name of withholder[:]([\w-\s]*)\s*)\n"
.Global = False
End Select
End With
There are a couple of ways to 'save' the found value, this is one:
if i = 1 then vText = Trim(M.SubMatches(1))
if i = 2 then vText2 = Trim(M.SubMatches(1))
if i = 3 then vText3 = Trim(M.SubMatches(1))
Mayank Manchanda says
Hi Diane,
I need to capture the Name, Number and Enquiry from outlook to excel. Is this possible. I receive 50 plus queries on daily basis from the real estate portal. Currently I copy data from outlook and paste it on excel manually but would like to automate that. Is this possible?
Diane Poremsky says
You can do it using a macro - the sample at https://www.slipstick.com/developer/regex-parse-message-text/#2 shows how to use a case statment to get different values from a message.
Jake says
Hello,
I am looking for a pattern that will give me only the string of numbers in a subject line-the structure is always the same but the names and the spaces are variable. The number of digits is always the same-6 digits period 2 digits: Example Subject: John Smith-French IRS 001234.87
Thank you
Diane Poremsky says
I think this pattern might work - "[A-Za-z -]*[0-9]{6}\.[0-9]{2}"
Jake says
Thank you for the fast reply!
I tried this and just get an empty cell in my excel file- Here is the pattern code I am using:
With Reg1
.Pattern = "[A-Za-z -]*[0-9]{6}.[0-9]{2}"
End With
If Reg1.test(hText) Then
Set M1 = Reg1.Execute(hText)
For Each M In M1
vText8 = Trim(M.SubMatches(1))
Next
End If
Diane Poremsky says
Did you set hText to be a value?
hText = olItem.Subject
Diane Poremsky says
This macro tests the pattern on the selected message - you need () around the pattern you want to pick up.
Sub TestPatterns()
Dim olItem As Outlook.MailItem
Dim vText8 As Variant
Dim hText As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
Set olItem = Application.ActiveExplorer().Selection(1)
hText = olItem.Subject
Debug.Print hText
Set Reg1 = CreateObject("VBScript.RegExp")
With Reg1
.Pattern = "([A-Za-z -]*[0-9]{6}.[0-9]{2})"
End With
If Reg1.test(hText) Then
Set M1 = Reg1.Execute(hText)
For Each M In M1
vText8 = Trim(M.SubMatches(0))
Next
End If
Debug.Print vText8
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
End Sub
Michael Morrison says
Will this macro work if an email is encrypted? I have the cert to decrypt my own email of course. Also, how about email attachments? Can we create a cell that contains a file path for email attachments?
Diane Poremsky says
Yes, on file attachments - that would be possible. I'm not sure about encryption - i think not, but i haven't tested it. (Will try to test it tomorrow.)
Steph says
Diane,
I tested the code in the VBA Editor and it works perfectly. The thing is that I the message I extract data from everyday at 3:00 am. Since I am not at work at 3:00 then my computer is either shut down or in power save mode. Is the macro supposed to work anyway because it does not seems to work presentely?
Diane Poremsky says
The macro will only run when outlook is running. When you restart it in the morning the macro should run.
Tony says
Just curious is it possible to amend this macro to run on a specific folder?
What I'm trying to achieve is to export all emails in my xyx folder which is a subfolder in my inbox.
I can do this via the File open & Export however I want to be able to trigger the email output externally to Outlook.
It's probably easy but I just cant find the resource
Thanks
Diane Poremsky says
The macro lower on the page is run on the selected folder.
Set objFolder = objOL.ActiveExplorer.CurrentFolder
if you want to run it automatically, you need to change it to an itemadd macro. See https://www.slipstick.com/developer/itemadd-macro/ for code. You'll use the first two macros on the page - in the first macro, you set the folder you want to watch. If it's a subfolder of the default inbox, it would be
Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox).folders("subfoldername")
in the second macro, replace the msgbox line with
CopyToExcel Item
And add the copytoexcel macro (first on this page) after the other two macros.
Kat Peschel says
I reworked this to pull specific info from my emails and all works great! Except, and this is a biggy... if the workbook is already opened, it locks up excel, doesn't close the workbook properly, so I get the "already in use" when I try to open the file again. I did not touch anything before the pattern part of the code. Please help!
Diane Poremsky says
This: Set xlApp = GetObject(, "Excel.Application") is supposed to use it if opened. It will 'lock' it up while the macro is running, but once it's finished, exchange should be usable again. You'll need to remove this line too - xlWB.Close 1 - so it doesn't close Excel.
Keith says
Diane,
I am adapting this solution for my needs, but I am trying to figure out the purpose of the first two lines of code.
Option ExplicitPrivate Const xlUp As Long = -4162
Diane Poremsky says
Option Explicit forces you to declare all variables.
Private Const xlUp As Long = -4162 sets a constant for xlUp. The value cannot be changed later by the code.
Bekkari says
thankx Diane for this code and sorry for my english
after i run the code nothing is happen
after that i read all previous comments and i see that you suggesed to uncoment this line; On error r3sume next and after that i do it, and i get an error 429 on this line; Set xlApp = GetObject(, "Excel.Application")
the error message was; an composant activeX cant creat object
i already activate Microsoft excel object lib
i use outlook 2010
so can you help please
Diane Poremsky says
Do macros work otherwise? I know that the old Office 2010 click to run version would have errors such as this but that was because that version of office didn't support macros.
Bekkari says
Yes they work i tested the info email to display email adress with specific word in subject in a msgbox
Bekkari says
in searching for the problem i found this code
Public Sub OpenMyExcelFile()
Dim File$
Dim Xl As Object ' Excel.Application
Dim Wb As Object ' Excel.Workbook
Dim Ws As Object ' Excel.Worksheet
Dim Rn as Object ' Excel.Range
File = "c:file.xls"
On Error Resume Next
Set Xl = GetObject(, "excel.application")
On Error GoTo 0
If Xl Is Nothing Then Set Xl = New Excel.Application
Set Wb = Xl.Workbooks.Open(File)
Set Ws = Wb.Sheets(1)
Ws.Activate
Set Rn = Ws.Range("a1")
Rn.Activate
Xl.Visible = True
End Sub
i try it and it work( it open the .xlsx file)
i try to adapt it to your code but i got the .xlsx file open and close instantaly
this is the new code;
Option Explicit
Private Const xlUp As Long = -4162
Sub CopyToExcel()
Dim File$
Dim olItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
'the path of the workbook
File = "C:\Users\okba\Downloads\file.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "excel.Application")
If Err 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
If xlApp Is Nothing Then Set xlApp = New Excel.Application
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(File)
Set xlSheet = xlWB.Sheets(1)
xlSheet.Activate
xlApp.Visible = True
Set olItem = Application.ActiveExplorer().Selection(1)
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*([\d-\.]*))"
End With
If Reg1.Test(sText) Then
' each "(\w*)" and the "(\d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
Diane Poremsky says
that is pretty much the same code I use in the original macro, but with different variables.
Try replacing this
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
with this
If xlApp Is Nothing Then Set xlApp = New Excel.Application
nmtm says
Hey!
Does this work with Yandex.mail as well?
I ask because I have an online registration form set up, whose information comes to my email from all the applicants. I have like 150 applicants data that I need on excel so far, and need desperate help!
Diane Poremsky says
As long as you use outlook, it works with any email account type... as long as yandex supports pop3 or imap, it will work.
ahmad says
In addition, I pasted both code samples and replaced the content with Sub CopyToExcel()
Dim olItem As Outlook.MailItem. After running the script, nothing happens. I would assume the excel workbook should automatically pop up?
Diane Poremsky says
it won't pop-up - we're not displaying it and close it when we're done writing to it. You need to open the excel file to look at it. And the excel file needs to exist - the code won't create it.
ahmad says
Hello,
This is my first time using macros. I ran the script but where does the excel file get stored on my pc after running the script? I can't seem to find it.
Diane Poremsky says
You need to create an excel workbook before you start - the code looks for a file named text.xlsx in your documents folder but you can change it by changing this line:
strPath = enviro & "\Documents\test.xlsx"
Chirag says
Very detailed information, i am trying to learn bit by bit...the code works fine for one pattern but i need to search for multiple patterns which are not in single paragraph..to be more specific i want 10 patterns ex: serviceno: , chgno: , description: those all are fields inside the body and i want their corresponding values in each column of an excel sheet in single row.
how can i do that? thanks alot for putting all the info up
Diane Poremsky says
See Get two (or more) values from a message section near the bottom of that link for an example showing how to use multiple patterns.
Gowtham says
Hi Diane,
I have an Email which contains counts in the mail. I want those counts to be present in their respective columns in the excel sheet. this should happen daily. i need to track this. Is there any coding for this.
Diane Poremsky says
As long as the values are identifiable, this macro should work - or a similar one that uses case statements if you have multiple values. See the second macro here - https://www.slipstick.com/developer/regex-parse-message-text/
Wojtek says
Hello,
Code is great but I have question about subfolders also will be exported? can be use those code to export data from few mailboxes and few folders (and subfolders)?
I appreciate your help.
Diane Poremsky says
No, the code as written only does the inbox (or a folder you are watching, depending on which macro you use). you would need to add code to walk the folder list. The macro at https://www.slipstick.com/developer/print-list-of-outlook-folders/ shows how to do it.
Megane says
Hi Diane, brilliant article, and thanks for all the information.
Instead of using excel for the output, i am simply trying to extract the full message from the email body into the text file.
I can use linux scripting to than pull the information i need, but struggling with getting the output to text file.
Please could you provide some guidance?
regards
Diane Poremsky says
You need to use the file system object to write to windows. The second macro at https://www.slipstick.com/developer/code-samples/save-email-message-text-file/ writes to a text file. (I'm not sure how you'd do on a mac.)
Jack says
Hi Diane, this has worked fantastically for me! I did want to see if there is a way to pull a specific line out of an email. I have some auto generated emails that come through and the second line changes daily (so there's no real commonality) but it's important I capture it. Any ideas?
Diane Poremsky says
It's always the second line? Is the first line something you could capture?
This should work for the pattern: ^[^\r\n]*\r?\n(.)\r?\n
This code sample can be used to test patterns - it writes the results to the immediate window (Ctrl+G) and is faster than testing it in the workbook.
Sub TextRegex()
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
Set olItem = Application.ActiveExplorer().Selection(1)
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
With Reg1
.Pattern = "^[^\r\n]*\r?\n(.*)\r?\n"
End With
If Reg1.Test(sText) Then
Set M1 = Reg1.Execute(sText)
For Each M In M1
' 0 = 1st set of () in pattern, 1 = 2nd set of ()...
vText = Trim(M.SubMatches(0))
Next
End If
Debug.Print vText
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
End Sub
Colin Thornton says
Hi Diane,
Thank you for providing this to everyone! A quick question: I am getting a
Run-time error '9':
Subscript out of range
error message on my
Set xlSheet = xlWB.Sheets("test")line. Any thoughts? Would I have to change the "test" to the actual location of the file? I am currently testing it for an existing email.Thanks!
Diane Poremsky says
that line is the name of the worksheet in the workbook - the workbook path is set here - Set xlWB = xlApp.Workbooks.Open(strPath). I'm guessing the workbook was found but the sheet inside it named test was not.
Colin Thornton says
I think we are getting closer. Now that it has recognized the name of the sheet, it shows that the value is
<Out of context>. Thoughts here?Diane Poremsky says
You're getting that error on the same line? Do you have spaces in the sheet name?
Thai says
Hi Diane!
I just wanted to come back and thank you - I finally got the code to work! Albeit, I had to request a change to our email formatting but with that change, it pulls perfectly. I did everything I could do to get it to extract with the current format but it just wouldn't work for me.
You were a great help along the way! Thanks!!
jack says
when i debug above code to "dim xlApp as Excel.Application" , there has a "compile error : user defined type not defined", would you tell me how to fix this error
Diane Poremsky says
Did you set a reference to excel in tools, references?
Dheeru says
hi Diane
error Subscription out of range
How to resolve this issue.
Diane Poremsky says
did it fail on Set xlSheet = xlWB.Sheets("Test") ? Does the workbook have a sheet named Test in it? Replace Test with the name of the sheet. (Default is Sheet1) (I'll change the sample to use Sheet1)
ALF says
HELP! I am new to VBA and Outlook. I am trying to download ALL e-mails from ALL folders and ALL subfolders to Excel. I copied the source above and it compiled. However, I cannot create the Run a Script Rule, as it is greyed out. Also, when I click on "Run" nothing seems to happen. Again, this is all new to me so I'm sure I'm missing a step.
Diane Poremsky says
This macro looks for a value in the email and puts that in excel. It doesn't do the entire message. The macro at https://www.slipstick.com/developer/code-samples/macro-export-outlook-fields-excel/ is more what you need, but it only does the mail in the currently selected folder. It could be converted to a run a script rule that works on messages as they arrive but would only work with messages in the inbox - running it manually after downloading the messages is probably the better method, at least to start.
Thai says
Hello Diane! This code worked wonderfully for me, until I realized that the email I was testing in was not standard to what I would need to run the code for. As it happens, the standard email will be HTML, starting with the standard <html xmlns:v="urn:schemas-microsoft-com:vml" in text view.
My problem?? When I run the code as is against the now standard email, the body returns as blank. When I change the code to HTMLBody, it does not find any of my variables, but I know they are there.
Are you able to help me change the code so that it will run exactly like it does now just for an HTML email??
Your help is greatly appreciated!!!!!
Diane Poremsky says
This should work ok with HTML messages as written.
Thai says
Hi Diane! The code I have is below. Unfortunately, as it is written when I step through it always shows the variables as empty. (You'll notice a lot of commented out code which I've been using as a reference and some of which I was testing.) Unfortunately I have to paste the code in two comments.
Option Explicit
Private Const xlUp As Long = -4162
Sub CopyToExcel()
Dim olItem As Outlook.MailItem
'Dim MailItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5, vText6, vText7, vText8, vText9, vText10, vText11, vText12 As Variant
Dim sText As String
'Dim rText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim Reg2 As Object
Dim Reg3 As Object
Dim M1 As Object
Dim M As Object
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Desktop\test.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Test")
Set olItem = Application.ActiveExplorer().Selection(1)
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
'sText = MailItem.HTMLBody
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "((RFP Code\w*)\s*(\w*)\s*(Lead Source\w*)\s*(\w*\s*\w*\s*\w*)\s*(Response Due Date\w*)\s*(\d*-\w*-\d*)\s*(Key Contact\w*)\s*(\w*\s*\w*\s*\w*\s*\w*)\s*(Planner Organization\w*)\s*(\w*)\s*(RFP Organization Type\w*)\s*(\w*))"
End With
'With Reg2
'.Pattern = "((Planner Organization\w*)\s*(\w*)\s*(\w*)\s*)"
'End With
Diane Poremsky says
Are the lines all one paragraph?
.Pattern = "((RFP Code\w*)\s*(\w*)\s*(Lead Source\w*)\s*(\w*\s*\w*\s*\w*)\s*(Response Due Date\w*)\s*(\d*-\w*-\d*)\s*(Key Contact\w*)\s*(\w*\s*\w*\s*\w*\s*\w*)\s*(Planner Organization\w*)\s*(\w*)\s*(RFP Organization Type\w*)\s*(\w*))"
if they are one line per label, try something like this - if \r doesn't work, try \n
.Pattern = "((RFP Code\w*)\s*(\w*)\s*\r(Lead Source\w*)\s*(\w*\s*\w*\s*\w*)\s*\r(Response Due Date\w*)\s*\r(\d*-\w*-\d*)\s*(Key Contact\w*)\s*(\w*\s*\w*\s*\w*\s*\w*)\s*(Planner Organization\w*)\s*\r(\w*)\s*(RFP Organization Type\w*)\s*(\w*))"
Thai says
Hi Diane! You don't know how much your help is appreciated - like without you, I've been banging my head for months!
This is a snippet of what the "view source" code looks like in the correctly formatted emails I am working with. There is multiple data I need to pull in different places in the code and each one is located deep within the code. When working in an email without the html header, it's at least kindof working, but I can't get it do anything now :(
*HEADER*
*CODE OF SOME DATA NEEDED* td width="137" nowrap="" valign="bottom" style="width:81.9pt;border:solid windowtext 1.0pt;border-top:none;padding:0in 5.4pt 0in 5.4pt;height:6.65pt">
REFERRED BY:
Rachel Gorin
Intermediary Partnerhsip
*CURRENT VARIABLES vText(1-12)**
RFP Code
(goes to a new line for the actual value)
Any thoughts??
Diane Poremsky says
So that code is what you see in the message body? or do you need to pull out of source code?
If you need to get from the source code, dubug.print item.body to see if the values are there - otherwise, you'll need to use item.htmlbody and will need to work around the html coding.
Thai says
Hi Diane!
Just wondering if you've had a chance to review my last post? Still plugging away on my end but not having any luck.
Diane Poremsky says
No, i hadn't yet. :( I need to clone myself so i can stay caught up.
Thai says
If Reg1.test(sText) Then
' each "(\w*)" and the "(\d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
vText3 = Trim(M.SubMatches(3))
vText4 = Trim(M.SubMatches(4))
vText5 = Trim(M.SubMatches(5))
vText6 = Trim(M.SubMatches(6))
vText7 = Trim(M.SubMatches(7))
vText8 = Trim(M.SubMatches(8))
vText9 = Trim(M.SubMatches(9))
vText10 = Trim(M.SubMatches(10))
vText11 = Trim(M.SubMatches(11))
vText12 = Trim(M.SubMatches(12))
'vText13 = Trim(M.SubMatches(13))
'vText14 = Trim(M.SubMatches(14))
'vText15 = Trim(M.SubMatches(15))
'vText16 = Trim(M.SubMatches(16))
'vText17 = Trim(M.SubMatches(17))
Next
End If
'Below commented out to use as reference for column headers
'ThisWorkbook.Sheets(1).Cells(1, 1) = "RFP Code"
'ThisWorkbook.Sheets(1).Cells(1, 2) = "Lead Source"
'ThisWorkbook.Sheets(1).Cells(1, 3) = "R"
'ThisWorkbook.Sheets(1).Cells(1, 4) = "SPR2"
'ThisWorkbook.Sheets(1).Cells(1, 5) = "SPR3"
'ThisWorkbook.Sheets(1).Cells(1, 6) = "SPR4"
'ThisWorkbook.Sheets(1).Cells(1, 7) = "ADMIN"
'ThisWorkbook.Sheets(1).Cells(1, 8) = "ADMIN2"
'ThisWorkbook.Sheets(1).Cells(1, 9) = "ADMIN3"
'ThisWorkbook.Sheets(1).Cells(1, 10) = "ADMIN4"
'ThisWorkbook.Sheets(1).Cells(1, 11) = "ADMIN2"
'ThisWorkbook.Sheets(1).Cells(1, 12) = "ADMIN3"
'ThisWorkbook.Sheets(1).Cells(1, 13) = "ADMIN4"
xlSheet.Cells(1, 1) = vText
xlSheet.Range("a" & rCount) = vText2
xlSheet.Cells(1, 2) = vText3
xlSheet.Range("b" & rCount) = vText4
xlSheet.Cells(1, 3) = vText5
xlSheet.Range("c" & rCount) = vText6
xlSheet.Cells(1, 4) = vText7
xlSheet.Range("d" & rCount) = vText8
xlSheet.Cells(1, 5) = vText9
xlSheet.Range("e" & rCount) = vText10
xlSheet.Cells(1, 6) = vText11
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Thai says
Your code has helped me immensely!!
I posted a response to your response but I don't see it approved yet but no rush. I do have another question though, is there a way for it to capture all text? As an example, the \w* \s* has to be there for every word and every space. The information I need to capture however is not consistent enough to hard code that in. Is there a way to say all words and spaces?? For example, I need to capture a name as a Sender Contact, but there's no way to know if they'll use 2 or 3 maybe even more names. How would I capture if they use more than 2??
Diane Poremsky says
You can use (.*) to get all text, but will need to use something to mark the end - could be \n or \r if the name is on one line.
Nas says
I have been trying this code. But no data is getting copied to the excel sheet. It just closes my excel sheet.
Diane Poremsky says
what pattern are you using? Try (.* as the pattern and see what it finds. Or add debug.print M.SubMatches(1) right after For Each M In M1 to see if it's picking up your pattern
DanBrenner says
This is AWESOME!!!!
I'm attempting to create a communication log for projects we've been running.
Is there a way I can adapt your code to pull in the body of the email (everything before the signature line) regardless of any specific pattern?
Diane Poremsky says
The biggest problem is in identifying the signature block. You can definitely get the body, trimming the signature needs a pattern (and the signature needs to fit the pattern).
DanBrenner says
I would be fine with pulling everything from the most recent email including the signature line. I wouldn't even be that upset if I could just pull the entire body of the email (including forwarded messages and all replies) into a single cell in an excel file.
Diane Poremsky says
This might be the problem > single cell in an excel file. Multiple lines are sometimes a problem - try this and see if it works for you.
xlSheet.Range("f" & rCount) = olItem.body
DanBrenner says
Hmmm. I replaced this segment of code:
.Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*([\d-\.]*))"
with your suggestion of:
xlSheet.Range("f" & rCount) = olItem.body
and I got an error at:
vText = Trim(M.SubMatches(1))
My guess is that I've changed the wrong section of your masterpiece here.
(Forgive me as I only know how to work with VBA in excel directly, outlook VBA is still completely new to me)
Diane Poremsky says
you won't use it to replace the pattern, but to replace a sheetrange line a few lines lower in the macro.
There isn't a lot of difference between Excel and Outlook - the basics are the same, most of the same functions work - only how you refer to messages and such is different.
Diane Poremsky says
oh and does this> body of the email (including forwarded messages and all replies)
refer to one message with a quoted messages in the body or separate messages within a thread? Getting separate messages in a thread is more difficult. If you can do it, putting them into one string to insert into a cell isn't a problem. I have no idea how much Excel can put in a cell, but that would be the only limitation.
P says
What sections of the code do I change to make work on my computer? I have a similar code that i use but the script is different.
What do i change here?
' Get Excel set up
enviro = CStr(Environ("USERPROFILE")) 'Is this the location of my Outlook profile? or the name of my outlook profile?
'the path of the workbook
strPath = enviro & "DesktopSYST DELETETest.xlsm" 'Is this the location of my excel workbook? Do i need to put the full path?
What other areas would I change? I copied the exact code into excel 2010 and I am getting a compile error. Any help would be appreciated.
Diane Poremsky says
This: enviro = CStr(Environ("USERPROFILE")) is the location of your user account in Windows - C:\Users\your-name. This allows the macro to work on any computer without a lot of configuring or creating folders.
This: strPath = enviro & "DesktopSYST DELETETest.xlsm" would be C:\Users\your-nameDesktopSYST DELETETest.xlsm - you need to add the slashes for the folders. strPath = enviro & "\Desktop\SYST DELETETest.xlsm" would be C:\Users\your-name\Desktop\SYST DELETETest.xlsm
Compile error means there is something wrong - could be the paths, could be something else. Does it highlight a specific line as the problem?
Anjuman says
I receive many mails in a day in specific format in my outlook 2013 mail as under:
Hi Company Name :others,
Your company vehicle/driver Name :Mr.Lorenzo Company Mobile Number : 3333333333 with the plate number :ML1122 has crossed the city max speed limit at :2015-12-18 12:05:27 Speed :75.0039 Current Address : 1, Sansad Marg Gokul Nagar, Sansad Marg Area New Delhi, Delhi 110001
Now the data before ":" sign is a fixed format and the credentials after ":" sign changes. Now my requirement is to gather this data in excel file and auto mail it to the CC and BCC address at every midnight. Please help
Diane Poremsky says
As long as you can identify the fields, you can use a macro. Are the fields in one paragraph or on separate lines? The only issue i see is that it might be harder to get the values.
The sample at the end of https://www.slipstick.com/developer/regex-parse-message-text/ shows how to get multiple values.
Select Case i
Case 1
.Pattern = "(Name\s[:]([\w-\s]*)\s*)"
.Global = False
Case 2
.Pattern = "(Number[:]([\d]*))"
.Global = False
End Select
Moritz says
Great article Diane! I just wanted to let you know that there is an alternative solution for people who don't want to code. With our app mailparser.io it's easy to extract data fields trapped inside e-mails to a more structure format (e.g. Excel Files).
Denise says
How about the other way around? Lets say I had a document containing a list of addresses and phone numbers for a list of about 150 employees. Lets say I wanted to take data from excel, plug it into the body and email destination fields from that sheet and run a macro to send a standard email, with each individuals' information plugged in. Impossible or is this 2015?
Diane Poremsky says
That would be a mail merge. You could do it in Word but it's also possible to do it using a macro. I have a macro that uses Outlook contact data - converting it to use Excel data wouldn't be hard, but Word can use Exchange as a data source, so i'd just use it.
Luis Monarres says
Hello Diane, Excellent code thanks. It worked for only one e-mail selected. How can I extract the information from many e-mail selected. The code "for each" is needed but I dont know where to put it.
Regards.
Diane Poremsky says
i have sample macros here - https://www.slipstick.com/developer/code-samples/working-items-folder-selected-items/ -
add the dim and set's to the top of the macro then put the for each stuff here - you could use 'for each olmail in selection', but i'm lazy and will set olmail to be the obj. :)
Set xlSheet = xlWB.Sheets("Test")
For Each obj In Selection
set olItem = obj
'Find the next empty line of the worksheet
[snip]
xlSheet.Range("f" & rCount) = vText5
Next
Cindy Treggiari says
Hello There,
This is a great code and once I can get it to work it will be wonderful! I have been working more and more with VBA snippets that I find online and tweak to get the results I need. I am completely unfamiliar with vba in outlook and how outlook communicates with excel. This was a struggle certainly for me. What I am trying to do is to have email responses from a specific sub-folder copied to an excel spreadsheet. Through your posts I took my excel data from a table with the 1st header reads "Vote With" followed by 13 additional headers. From the response email, I only want to pull in the 2nd line of the table as there are blank fields the user may populate. When the user replies I would like the 2nd line and any additional body text (not the header) to populate my excel spreadsheet.
I have based my Reg1 search on this pattern:
"Vote With" is the header of the 1st column...
.Pattern = "((Vote_With\s*[:]\s*\r(\w*)\r))"
But I get an error at this line
Run=time error '440': Array index out of bounds
Set olItem = Application.ActiveExplorer().Selection(1)
I removed that...because I read elsewhere in your posts to remove it if I want to copy all the emails to the spreadsheet not just what I selected.
Now I get an error: Run-time error '1004':
Application-defined or object-defined erorr.
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
Here is the code:
Option Explicit
Sub CopyToExcel()
Dim olItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\ProxyActiveTesting\2015 ProxyTEST.xlsm"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Test")
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "((Vote_With\s*[:]\s*\r(\w*)\r))"
End With
If Reg1.test(sText) Then
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
vText3 = Trim(M.SubMatches(3))
vText4 = Trim(M.SubMatches(4))
'vText5 = Trim(M.SubMatches(5))
Next
End If
xlSheet.Range("B" & rCount) = vText
xlSheet.Range("c" & rCount) = vText2
xlSheet.Range("d" & rCount) = vText3
xlSheet.Range("e" & rCount) = vText4
xlSheet.Range("f" & rCount) = vText5
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Diane Poremsky says
you need Set olItem = Application.ActiveExplorer().Selection(1) if you are running the macro on a selected message. If you are using a run a script rule or calling it from a second macro, the macro name needs to be in this format:
Sub CopyToExcel2(olItem As Outlook.MailItem)
The other line (with xlUp) was erorring for me, but with a different error message. Setting a reference to Excel in Tools, References fixed it. it should work without setting the reference though.
Diane Poremsky says
Well i can repro your error - if i don't use option explicit, i get the 1004 error.
Add this line to the code - it should work then - or at least, make it to the stext = olitem.body line.
Private Const xlUp As Long = -4162
Add this above the stext line if you are using the run a script version.
Set olItem = Application.ActiveExplorer.Selection.Item(1)
Maurice says
Hello Diane, this is my first time with VBA and Outlook. What I wanted to do is to extract email adressess from failure notifications' bodies. I sent a Christmas and New Year card to my contacts, but some of them were returned as failed (700+), so I want to extract their emails into a xls document.
I would really appreciate your help. Thanks beforehand.
Diane Poremsky says
I have a macro at https://www.slipstick.com/developer/categorize-contacts-bad-addresses/ that categorizes contacts that NDR - grab the pattern from it. Remove the extra vtext lines and it should work fine.
Alex says
Hello,
First, thanks for the macro, it works very well !
I wanted to know if that possible to extract those information and export them to an excel file, instead of adding them as a contact ?
If yes, how can I do it ? I am a beginner in VBA but willing to learn :)
Thanks
Diane Poremsky says
The macro on this page will do just that. If you just want the sender name and email address, you don't need the code that looks for the pattern matches. Change these lines to use the fields
xlSheet.Range("B" & rCount) = olitem.sendername
xlSheet.Range("c" & rCount) = olitem.senderemailaddress
Walker Smith says
Hi Diane,
I have a problem in that the code opens the 1st read copy of what is in the inbox, rather than what has just arrived (unread).
Any help would be greatly appreciated.
Thanks,
Walker
Walker Smith says
Hi Diane,
I have resolved my problem (I think?).
It seems that all my issues are associated with the fact that I was testing this by emailing myself.
I don't know why, but I can't get this rule to run a script, when emailing myself. It only works when I receive the email from another user.
I don't really understand this, so if you have an explanation, I'm all ears.
Thanks so much for your help... You have a great website with so much free information.
Take care
Walker
Diane Poremsky says
What was the rule condition and are you using Exchange server? If so, you can't use a condition that checked the SMTP address or the message header because Exchange mail doesn't have a smtp address or a header.
Walker Smith says
Hi Diane,
I am using your code above, but it is copying the 1st read message in the folder, rather than the message that was just sent (unread).
TIA for any help.
Walker
Diane Poremsky says
The macro (as written) is triggered by an incoming rule. If you want to work with sent items you'll need to use the ItemAdd macro and watch the sent folder. An example of an itemadd macro is here: https://www.slipstick.com/developer/code-samples/use-vba-move-messages-based-values-fields/
Walker Smith says
Hi Diane,
So I misstated my issue and I apologize for the confusion.
Yes, I have set up a rule that:
1) Applys this rule after the message arrives
2) Where my name is in the To or CC box
3) And with "Test Results" in the subject
4) And on this computer only
5) Move to the "Training records" folder
6) And run "Project1.CopyToExcel"
Now when the message arrives, it generates an error message that says "Rule failed to execute"
And the rule is unchecked in the Rules and Alerts drop down menu.
The email does end up in the "Training Records" folder per the rule's logic.
So I have determined that the problem is an error in the script.
Unfortunately, the script with an argument can't be debugged (at least I don't know how to do this), so I changed the script to run manually as instructed, so I can use the F8 key to go line by line to see what is going on.
I put the message in the Inbox and debugged the script and I found that the contents of sText were associated with the 1st read message in the Inbox, rather than the message that was sent for the debugging and was unread.
Now if I read the message and then manually run the script, everything runs perfectly with the data put in the Excel file.
Perhaps I am missing something associated with debugging the script manually?
I have concluded that the script throws an error, for the case where it is triggered by the rule because when it arrives, it is the only message in the box and is unread.
Perhaps I am wrong about this, and there is a problem with the way the rule is setup.
Regardless, thank you so much for your help and I look forward to any suggestion that you might have.
Walker
Walker says
Hi Diane,
For some reason "If Reg1.test(sText) Then" is yielding a False and is skipping the heart of code. The watch list show that sText is populated. Do you have any suggestions.
Thanks in advance for your help.
Walker
Walker says
Hi Diane,
This a great resource that you have provided...thanks so much.
I am having an issue that was discussed in this link:
https://www.slipstick.com/developer/vba-copy-outlook-email-excel-workbook/#comment-187748
My problem is that I am getting the 1st line of the email only and M is "Nothing."
Consequently, no text is inserted into the spreadsheet.
Any help would be greatly appreciated.
BTW, I have the following objects referenced:
1) Microsoft Excel 15.0 Object Library
2) Microsoft VBScript Regular Expressions 5.5
I hope the latter is not my problem.
Thanks and take care,
Walker
Diane Poremsky says
It's not the references - the macro would error if they weren't set correctly.
What pattern are you using?
Colm says
I need to read a table from an email and place it into excel, the format is as follows:
ID result
1 pass
2 pass
3 fail
I have used your code as a base to build on however I am unable to get it working. The rule in outlook works and moves the email into its own folder called test but it doesn’t split up the email or enter the information into excel, below is my code, any ideas?
Option Explicit
Private Sub BrainCallBack(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim rows As Variant
Dim numberofColumns As Long
Dim numberofRows As Long
Dim headerValues As Variant
Dim headerRow() As String
Dim data() As String
Dim i As Long, j As Long
Dim Ns As Outlook.NameSpace
Dim objItems As Outlook.Items
Dim objFolder As Outlook.MAPIFolder
Dim olMail As Object
Set Ns = Application.GetNamespace("MAPI")
Set objFolder = Ns.GetDefaultFolder(olFolderInbox).Folders("test")
'Error in above line: The attempted operation failed. An object could 'not be found.
Set objItems = objFolder.Items
For Each olMail In objItems
enviro = CStr(Environ("cd47289 on RDCSKZPVT006"))
'the path of the workbook
strPath = "cd47289 on RDCSKZPVT006" & "\\My Documents\Book1.xlsx"
Debug.Print strPath
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Book1")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.rows.Count).End(xlUp).Row
rCount = rCount + 1
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
' calculate array size
numberofColumns = Len(rows(0)) - Len(Replace(rows(0), Chr(9), ""))
numberofRows = UBound(rows) + 1
' put header row into array
ReDim headerRow(1 To numberofColumns)
headerValues = Split(rows(0), Chr(9))
For i = 1 To numberofColumns
headerRow(i) = Trim$(headerValues(i - 1))
Next i
' calculate data array size
numberofRows = numberofRows - 1
' put data into array
ReDim data(1 To numberofRows, 1 To numberofColumns)
For i = 1 To numberofRows
For j = 1 To numberofColumns
data(i, j) = Trim$(Split(rows(i), Chr(9))(j - 1))
Next j
Next i
End Sub
Diane Poremsky says
if you are using a run a script rule, the script should do all of the actions - the rule handles the conditions only. An rule and an item add macro would work instead - anything dropped into the folder would be processed by an itemadd macro.
>> Set objFolder = Ns.GetDefaultFolder(olFolderInbox).Folders("test")
'Error in above line: The attempted operation failed. An object could 'not be found.
Does a folder named text exist under the inbox?
This line: For Each olMail In objItems runs the macro on all messages in the folder each time. You probably don't want that. :)
Diane Poremsky says
Unless the table that holds the data you need can be identified using regex patterns, you'll need to use another method to pick up the values. You might be able to use word vba to grab it - this gets the value in row 1 column 3. I don't know the command offhand to grab the entire table, but you might be able to put it into an array.
Dim myTable As Word.Table
Set myTable = ActiveDocument.Tables(1)
myTable.Cell(1, 3).Select
txtValue = myTable.Cell(1, 3)
ssibsm says
ok..I have a basic knowledge about excel and am trying to learn new things...need some help with this..
Example:I have made a Time sheet in excel for John..as John is not tech with IT....in this time sheet I have added details,login,logout,formulas for calculating the total hours etc...so when John receives it he just have to put the login and logout timings and the remaining is calculated automatically...
so here is my question,
1)can i email this active workbook as a body of the email(Not as attachment) to John??
2)And when John receives the email he should be able to fill the sheets with timings in the active worksheet in the email itself and forward me back the same email.(No need to download,fill,attachment and send back headache for John)
3)which mail supports this....I use outlook 2007...
so I was just wondering is there any thing like this and Detailed Answer is much appreciated...Thanks in advance
Diane Poremsky says
1. No, not as rule. If you are using Exchange server, you could embed it in an RTF message then the formulas will work. If you are using macros, they won't work. If it gets sent to a smtp address, outlook will convert it to HTML and the spreadsheet won't work.
2. Only if you can use RTF.
3. As long as you use RTF message format, you can embed sheets in the message in all versions.
arnold says
Hi Diane!
Pardon the newbie question, I've used Excel VBA before but this is my first time to try Outlook.
Where exactly do can I call the CopyToExcel function and what arguments do I need to pass?
I tried calling it from a form button but cant really figure out what argument to pass.
I basically need to process emails from an automated server that sends me alarm data from process equipment.
Thanks!
Arnold
Diane Poremsky says
It's a run a script rule macro - you'll add it to a rule. To test it, or to run it manually, you can use this to call the macro and run it on the selected item.
Sub RunMacro ()
Dim olItem As Outlook.MailItem
Set olItem = Application.ActiveExplorer().Selection(1)
CopyToExcel olItem
End Sub
Posky says
Thanks Dianne, the fields i need to extract from the e-mail are:-
1. Date e-mail received
2. Date e-mail sent
And it is a certain spreadsheet I need it to update every time and email is sent and received.. Can you provide the code please?-
Thanks very much..
Diane Poremsky says
this macro watches the sent and inbox folders and writes the time, subject, and to fields to a spreadsheet. I needed to set a reference to excel to use it.
Posky says
Hi, the code is very similar to something I need:-
Scenario:- I have a xls file with fields like date and a names of 2 folders I have on outlook, I was looking for whenever an e-mail is sent to update the date it was sent and whenever an e-mail is received in that folder to update the date in the excel file......any suggestions??
Many Thanks
Diane Poremsky says
You'll want to use itemadd to watch folders and an itemsend macro to watch sent items... if you kept sent items with the original when the original is not in the inbox, the itemadd macro also get the sent items.
If you don't need to capture data from the message body and are only using data in Outlook fields, you won't need all the reg stuff (everything from sText = olItem.Body through xlSheet.Range("f" & rCount) = vText5), just something like this for each field you need:
xlSheet.Range("B" & rCount) = olitem.senton
Janel Losoya says
Hi Diane,
Thank you for this article. It is extremely helpful. I am testing this code for an email that contains the following information:
Company: ABC Company
Class Period: 2013-10-29 through 2014-10-22
I have set up a For With loop to go through the email and insert the Company Name in one column, the first date (2013-10-29) in the second column and the other date (2014-10-22) in the third column. When I run my code I receive an error that states: Run-time error 5: Invalid procedure call or argument on the below line of code:
vText2 = Trim(M.SubMatches(2))
Could you please let me know what I am doing wrong.
Option Explicit
Sub CopyToExcel()
Dim olItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
Dim i As Long
'the path of the workbook
strPath = "\\mypath"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Test")
Set olItem = Application.ActiveExplorer().Selection(1)
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
For i = 1 To 3
With Reg1
Select Case i
Case 1
.Pattern = "(Company\s*[:]+\s*(\w*\s*\w*\s*\w*\s*\w*\s*\w*\s*\w*\s*\w*\s*\w*\s*\w*\s*)\n)"
.Global = False
Case 2
.Pattern = "(Class Period\s*[:]+\s*([\d-\s]*))"
.Global = False
Case 3
.Pattern = "(through+\s*([\d-\s]*))"
.Global = False
End Select
End With
If Reg1.Test(sText) Then
' each "(\w*)" and the "(\d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
vText3 = Trim(M.SubMatches(3))
Next
End If
Next i
xlSheet.Range("A" & rCount) = vText
xlSheet.Range("B" & rCount) = vText2
xlSheet.Range("C" & rCount) = vText3
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Additionally, I have a RegEx question. How do you pull characters such as a hyphen and text with spaces? For example I would like to pull text in my email that is formatted like this:
Court: USDC - New York (Southern)
Thank you!
Diane Poremsky says
The number in this: vText2 = Trim(M.SubMatches(2)) tells it to look for the 3rd set of (), not to use case 3.
Try something like this instead - with each case assigning the cell column to a string.
Case 1
.Pattern = "(Company\s*[:]+\s*(\w*\s*\w*\s*\w*\s*\w*\s*\w*\s*\w*\s*\w*\s*\w*\s*\w*\s*)\n)"
.Global = False
strCell = "A"
' repeat for each case
For Each M In M1
vText = Trim(M.SubMatches(1))
xlSheet.Range(strCell & rCount) = vText
Next
End If
Next i
Anand.V says
Hi Diane,
Your blog is very nice. I am a newbie to VBA. require some guidance in my requirement.
I am getting some exception emails in outlook and I need to read it and move it to an excel sheet to create some kind of reports. could you please help n this
Diane Poremsky says
What kind of reports do you need? What do you have so far for the code?
Dan says
Dear Diana,
Thanks a lot for the developed code, I find it incredibly useful in my workflow. May I ask for assistance, I need to revise a piece of code so that it gives me the exact location of emails in folders / subfolders?
For instance, I used this code
strColC = olItem.Application.ActiveExplorer.Caption
A selected message is located “My account\TC-15\Advanced Control” folder and I need the code to give me output such as “\\My account\TC-15\Advanced Control\Advance Control (M).msg”, but instead I am getting “Advance Control (M) – My account – Outlook”.
I look forward to hearing from you
Diane Poremsky says
This will get the folder path of the current item - work it into the code you are using
Sub PrintFolderPath()
Dim folder As Outlook.MAPIFolder
Dim folderPath As String
Set folder = Application.ActiveExplorer.Selection.Item(1).Parent
folderPath = folder.Name
Do Until folder.Parent = "Mapi"
Set folder = folder.Parent
folderPath = folder.Name & "\" & folderPath
Loop
Debug.Print folderPath
End Sub
William says
Hi,
This sample has been fantastic in helping, im wondering if there is a way to pull the email address out of the the below
"A message that you sent could not be delivered to one or more of its recipients. This is a permanent error. The following address(es) failed:
fdslknclds@dknvclksd.cpmd
Unrouteable address
"
Any help would be greatful.
Thanks
William
Diane Poremsky says
You can - i have a code sample at https://www.slipstick.com/developer/categorize-contacts-bad-addresses/
Jon says
I'm sorry, I'm not really able to see what the issue is as I'm new at working with this, I was hoping it would be possible to get an example which would work for what I was looking for. I appreciate the time you have spent to help me out thus far.
Diane Poremsky says
Are you calling the correct path? Add debug.print strpath after the strpath = line. Enviro uses the user path automatically, if you need a different path it should be hardcoded into strpath.
enviro = CStr(Environ("\\shedevil\brainiacs"))
'the path of the workbook
strPath = enviro & "test.xlsx"
Jon says
I comment out the on error and it runs through, but does not output to the excel document. I'm familiar with the step into on the macro edit for excel, however I am not getting an option to step into by pressing f8 from the VBA design, or by pressing f8.
Diane Poremsky says
I always use the command on the Debug Toolbar.
Jon says
that took care of the code, however it still doesn't output anything to the excel file, are you able to in testing?
Diane Poremsky says
do you get any error messages? Try stepping into the macro (using F8 or the Step into command on the Edit toolbar) and see if it skips lines. oh, and remove or comment out the on error resume next line - that will cause it to stop when it hits an error so you can see what is failing.
Jon says
I also added Dim i As Object, now i'm getting a syntax error on this line:
Dim vText, vText2, vText3, vText4, vText5, vText6, vText7, vText8, vText9, As Variant
Is there something anything else I'm missing?
Diane Poremsky says
i isn't an object - its a number - dim it as a variant instead.
Jon says
Thank you Diane, this is what I currently have, however it's giving me an error saying variable is not defined on this line:
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
The current full macro I have is here, did I do the part right to have it right to the excel spreadsheet?
Option Explicit
Sub BrainCallBack(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
enviro = CStr(Environ("\\shedevil\brainiacs"))
'the path of the workbook
strPath = enviro & "test.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Test")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
'.Pattern = "(CRR\s[:](\w*))\n"
'use this for the single letters (with the correct labels):
'.Pattern = "(Sub\s[:]([A-Z]))\n"
'.Pattern = "(Account\s[:](\d*))\n"
'Use this one for name, callback, phone, and comment (changing the labels of course):
'.Pattern = "(Name\s[:](.*))\n"
With Reg1
Select Case i
Case 1
.Pattern = "(CRR\s[:](\w*))\n"
.Global = False
Case 2
.Pattern = "(Sub\s[:]([A-Z]))\n"
.Global = False
Case 3
.Pattern = "(Account\s[:](\d*))\n"
.Global = False
Case 4
.Pattern = "(Date[:]([\w-\s]*)\s*)\n"
.Global = False
Case 5
.Pattern = "(Name\s[:](.*))\n"
.Global = False
Case 6
.Pattern = "(Callback_time\s[:](.*))\n"
.Global = False
Case 7
.Pattern = "Phone\s[:](.*))\n"
.Global = False
Case 8
.Pattern = "(Ok_to_call_after_9pm\s[:](.*))\n"
.Global = False
Case 9
.Pattern = "(Comment\s[:](.*))\n"
.Global = False
End Select
End With
If Reg1.test(sText) Then
' each "(\w*)" and the "(\d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
vText3 = Trim(M.SubMatches(3))
vText4 = Trim(M.SubMatches(4))
vText5 = Trim(M.SubMatches(5))
vText5 = Trim(M.SubMatches(6))
vText5 = Trim(M.SubMatches(7))
vText5 = Trim(M.SubMatches(8))
vText5 = Trim(M.SubMatches(9))
xlSheet.Range("A" & rCount) = vText
xlSheet.Range("b" & rCount) = vText2
xlSheet.Range("c" & rCount) = vText3
xlSheet.Range("d" & rCount) = vText4
xlSheet.Range("e" & rCount) = vText5
xlSheet.Range("g" & rCount) = vText6
xlSheet.Range("h" & rCount) = vText7
xlSheet.Range("i" & rCount) = vText8
xlSheet.Range("f" & rCount) = vText9
rCount = rCount + 1
Next
End If
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
'Customize the code
'If you need to throw the entire line into one cell, you'll use the following code snippet. You could use a shorter pattern. (In my testing, the line wrapped in the cell automatically using the shorter pattern.)
.Pattern = "((P130[\w*-\s*]*[\d-\.]*))"
With Reg1
' the entire string in one variable
.Pattern = "((P130\w*\s*\w*\s*\w*\s*\w*\s*[\d-\.]*))"
End With
If Reg1.test(sText) Then
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
Next
End If
xlSheet.Range("B" & rCount) = vText
xlWB.Close 1
Diane Poremsky says
Try setting a reference to Excel in the VB Editor's Tools, References. It shouldn't need it, but I was getting the same error the other day and it went away when I set the reference.
Jon says
I find this article very helpful, however I am very new at all this. what changes would I need to make to allow it to copy the following format to an excel sheet named test on tab test? The results could be put in the bottom row columns, A:I. Also, I could add a ":" at the end of Comment if needed.
CRR: mkrieger
Sub: Y
Account: 2733863
Date: 2/6/15
Name: Mr Customer
Callback_time: As soon as possible 'may also have a time such as 9pm'
Phone: 419-555-1212
Ok_to_call_after_9pm: Y
Comment
Requesting to speak with the guy, please give customer a callback as soon as possible. Thanks!
Diane Poremsky says
the second macro at https://www.slipstick.com/developer/regex-parse-message-text/ shows how to get different values from a message.
Each case needs a pattern -
.Pattern = "(CRR\s[:](\w*))\n"
use this for the single letters (with the correct labels):
.Pattern = "(Sub\s[:]([A-Z]))\n"
.Pattern = "(Account\s[:](\d*))\n"
Use this one for name, callback, phone, and comment (changing the labels of course):
.Pattern = "(Name\s[:](.*))\n"
Mark says
Hello Diane,
Please could you explain why my script isn't working? I have tried this:
sText = olItem.Body
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Set Reg1 = New RegExp
'Set Reg1 = CreateObject("vbscript.regexp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "\[\*\]\s(\d\d\/\d\d\/\d\d\d\d\s\d\d\:\d\d\:\d\d)\s\:\sTransaction\sDeal\sList\s\-\sScheduled\_LONDON"
.Global = True
End With
If Reg1.Execute(sText) Then
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
xlSheet.Range("B" & rCount) = vText
rCount = rCount + 1
Next
End If
But it seems to be giving me an error, I've been looking in the Watches and it shows the value as Empty.
I'm using Outlook 2010. Thanks :)
Diane Poremsky says
I'd look at the pattern. I'd remove all the consecutive \d and use \d*. Maybe test it with "\s(\d*)[:]" and see what you get. Oh. Sincwe you only have one set of parens (), try using submatches(0) or add another set of parens.
Jon says
I am very interested in deploying something like this to a rule for messages we receive for suspended e-mail addresses. What lines would I need to replace with what data to search through the subject, or the body of the message for an e-mail address? Is it also possible to pull the date it was received and output it in excel? The e-mail domains consist of *@dom-ain.com, and *@domain.net. The subjects are: AUP Suspension of account : *@domain.net
The body is:
Hello,
The following account has been suspended due to complaints received by
recipients regarding the content of the messages having abusive spam
behaviour and/or massmailing patterns within the OpenSRS Hosted Environment.
This is due to repeat complaints from recipients and/or high volume outbound
spam.
We have taken the following action:
* Placed this end user under AUP Violation
* Placed this end user on our internal abuse list
Please take the following actions:
* Inform the account owner of the reasons for suspension (provide evidence
as needed)
* Take appropriate action to ensure this activity does not continue.
* Remove the AUP Violation flag or permanently disable the account
The account in question is:
*@domain.net
IMPORTANT: If you determine that this account name is NOT related to repeat
spammers, and is legitimate, please let us know ASAP, or as new accounts are
created that have a similar pattern, they may also be suspended.
Any input is greatly appreciated
hruday kulkarni says
HI,
Can you please provide me macro script for outlook.
I need macro where all text in the body of mail is selected and deleted.
Can you please assist.
Thanks in anticipation..
Diane Poremsky says
use .body = "" to remove the message body. Don't forget to save it - otherwise the body won't be deleted from the message.
Sanjay chaurasia says
hi, I've used this macro, please provide the coding for copying the mails from sent items..
Diane Poremsky says
The macro on this page works on messages as they are received. If you want to save messages you are sending, you need to use an itemadd macro or run a macro on the selected items later. An example of an itemadd macro watching the sent folder is on this page: https://www.slipstick.com/developer/automatically-print-messages/ - replace the print code with the macro on this page.
gemneedham says
hi, I've used this macro, it's working, but it's only filling my excel up to 1544 rows, there's more data than this, what am I doing wrong?
Diane Poremsky says
Try changing
xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
to
xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
Ben says
Hi Diane,
I have now managed it to get the first and last name and add it to the xls without the word Name: on the side which is what im after. I now have to work out how to loop it to get the other fields and add them to new column's. Then to do the same for the whole folder. Below is what I have so far.
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "((name[:])\s*(\w*)\s*(\w*))"
End With
If Reg1.test(sText) Then
' each "(\w*)" and the "(\d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
vText3 = Trim(M.SubMatches(3))
'vText4 = Trim(M.SubMatches(4))
'vText5 = Trim(M.SubMatches(5))
Next
End If
'xlSheet.Range("B" & rCount) = vText
xlSheet.Range("c" & rCount) = vText2
xlSheet.Range("d" & rCount) = vText3
xlSheet.Range("e" & rCount) = vText4
xlSheet.Range("f" & rCount) = vText5
Thanks.
Diane Poremsky says
with a long list, it will be easier to use case statements, although, if the only colons are in the labels, you could use (\w)[:] to search for every word.
the link i posted earlier has more information, but this is the basic idea - change 3 to the # of queries then loops through them.
For i = 1 To 3
With Reg1
Select Case i
Case 1
.Pattern = "(Order ID\s[:]([\w-\s]*)\s*)\n"
.Global = False
Case 2
.Pattern = "(Date[:]([\w-\s]*)\s*)\n"
.Global = False
Case 3
.Pattern = "(([\d]*\.[\d]*))\s*\n"
.Global = False
End Select
End With
Ben says
Hi Diane,
Thanks for your prompt reply :-) I gave that a try but returned nothing with n or r.
Option Explicit
Sub CopyToExcel()
Dim olItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\test.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Test")
Set olItem = Application.ActiveExplorer().Selection(1)
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
rCount = rCount + 1
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
'.Pattern = "((nam\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*([\d-\.]*))"
.Pattern = "name\s*[:]\s*\r(\w*)\r"
End With
If Reg1.test(sText) Then
' each "(\w*)" and the "(\d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
vText3 = Trim(M.SubMatches(3))
vText4 = Trim(M.SubMatches(4))
'vText5 = Trim(M.SubMatches(5))
Next
End If
xlSheet.Range("B" & rCount) = vText
xlSheet.Range("c" & rCount) = vText2
xlSheet.Range("d" & rCount) = vText3
xlSheet.Range("e" & rCount) = vText4
xlSheet.Range("f" & rCount) = vText5
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Diane Poremsky says
Does it find the name? Add a Debug.print M.SubMatches(0) then run it and check the immediate window (View > Immediate window) Because there is only one set of (), you'll use for the submatch.
(You'll need a pattern for each - it will be better to use select case - the second macro at https://www.slipstick.com/developer/regex-parse-message-text/ shows how.)
Ben says
Hi Diane,
I have a form sent with headers and the data in the next line as below. How would I go about it looking for the header and then taking the line under and adding it to the sheet? I would need it to loop through all emails in a folder.
name:
Matthew hills
email:
qwerty@hotmail.com
Make:
Volkswagon
Model:
amarok
Year:
2014
Postcode:
4518
Front bar:
No
Rear bar:
Yes
Rock Sliders:
No
Under Body Protection:
No
Thanks in advance.
Ben
Diane Poremsky says
Try something like
.Pattern = "name\s*[:]\s*\n(\w*)\n"
\r & \n represent carriage return and line feed. If one doesn't work, try the other.
Felipe Soares says
Thank you soooo much Diane! It works!
There is just one more thing that is not going very well. Do you have any idea about why is it jumping one column when copying to excel?
A B C D
cdi over SM 589059635
cdi over SM 903988960
cdi over SM 152652139
cdi over SM 796778481
im separating like this:
With Reg1
.Pattern = "((cdi \w*)\s*(\w*)\s*(\w*))"
.Global = True
It should be like this:
A B C
cdi over SM 589059635
cdi over SM 903988960
cdi over SM 152652139
cdi over SM 796778481
Thak you very much again!
Diane Poremsky says
It's in the cell code:
xlSheet.Range("B" & rCount) = vText
Adjust the column letters as needed.
Felipe Soares says
Is it possible to do that if I want to select more lines?
For example,I have to do the same task (extract from email body and copy in excel sheet) but with an email that comes in this format:
cdi over SM 589059635
cdi over SM 903988960
cdi over SM 152652139
cdi over SM 796778481
I've used your code but it only returns me the first line to excel. The number of lines in the email body is uncertain, so i'd need a code that would count the lines in the email body and run your code for each one of them. Is it possible (or is there an easier way to do that)?
Thank you so much!
Diane Poremsky says
You need the End if line after the lines (ex. xlSheet.Range("B" & rCount) = vText) that write to the sheet
You will probably also need to add .Global = True under the .pattern line.
Felipe Soares says
Thanks Diane,
I've just tried it but now the code is copying only the last line of the body =/
This is how it looks now:
With Reg1
.Pattern = "((cdi \w*)\s*(\w*)\s*(\w*))"
.Global = True
End With
If Reg1.test(sText) Then
' each "(\w*)" and the "(\d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
vText3 = Trim(M.SubMatches(3))
'vText4 = Trim(M.SubMatches(4))
'vText5 = Trim(M.SubMatches(5))
Next
xlSheet.Range("A" & rCount) = vText
xlSheet.Range("c" & rCount) = vText2
xlSheet.Range("d" & rCount) = vText3
'xlSheet.Range("e" & rCount) = vText4
'xlSheet.Range("f" & rCount) = vText5
End If
Diane Poremsky says
Try it this way (moving the sheet ranges inside of the Next loop) - you need to write to the workbook before it loops. Oh, and you need to increate the row count, otherwise it will write to the same row over and over.
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
vText3 = Trim(M.SubMatches(3))
'vText4 = Trim(M.SubMatches(4))
'vText5 = Trim(M.SubMatches(5))
xlSheet.Range("A" & rCount) = vText
xlSheet.Range("c" & rCount) = vText2
xlSheet.Range("d" & rCount) = vText3
'xlSheet.Range("e" & rCount) = vText4
'xlSheet.Range("f" & rCount) = vText5
rCount = rCount + 1
Next
End If
swati iyer says
Hi Diane,
I have an excel macro that picks up only one folder at a time. Is there a possibility of making the macro pick data from multiple folders?
Thanks
Swati
Diane Poremsky says
You can do it if you use something like the processfolder macro on this page - https://www.slipstick.com/developer/print-list-of-outlook-folders/
Nilesh M says
Thanks a lot Diane...this is simply amazing...i am also looking for the same where email body to be pasted in the excel file... so i have some questions.
1.Will it work when outlook is not open?
2.The data which will be pasted can we aligned or standardize them header wise?
Diane Poremsky says
1. No, it won't work if outlook is not opened. It's a run a script rule and only runs in Outlook.
2. Yes, you should be able to apply any formatting Excel can apply using a macro. In Excel, record a macro applying the formatting so you know how it is written then select the cell and apply the formatting in the outlook macro.
Mukesh says
Hi DIane,
Thanks a lot for the post, it's by far the simplest solution I have come across so far. Like Carlos, I require the entire email body to be pasted to the excel file. I made the changes suggested by you but by doing that the entire body of the mail is pasted to a single cell. It's actually a table in the email. Can you please suggest the change I should be making to the code.
Thanks.
Diane Poremsky says
if you want to paste it into excel as a row or table, you need to use delimiters so Excel knows the data should go into more than one cell, or you need to split it and send it to the correct cell. The sample on this page grabs data in outlook and sends it to different cells.
Jayson Dunne says
Diane,
That works!
the sub has essentially been handed the incoming mail by the rule, and the line you suggest deleting selects another mail.
thanks for the help
Jayson
Jayson Dunne says
Diane,
thanks.
The code does trigger from the rule, exactly as you describe.
However the mail it chooses to manipulate is not the incoming mail which meets the rule criteria. It operates on the mail I have selected in my inbox.
I've tried it under different views and the problem persists.
Is this perhaps a 2007 issue? If so do you have any thoughts as to a solution ?
Jayson
Diane Poremsky says
It should work fine under outlook 2007. Try removing this line: Set olItem = Application.ActiveExplorer().Selection(1)
It's needed to run it manually on the current item and will definitely cause the problem you described.
Jayson Dunne says
Diane,
I find that this opens the mail I have SELECTED, not the new, incoming mail.
If I don't have a mail selected (i select the "Date:Today" header) then it fails.
How can I be sure it runs on the incoming mail that triggered the event?
I'm running Outlook 2007.
It's essentially the same as Carlos's problem above
Jayson
Diane Poremsky says
This macro runs with a rule and should be triggered if the rule is triggered.
Sub CopyToExcel(olItem As Outlook.MailItem)
If you edited the code and are running it manually, you could add a statement that triggers an alert if a message is not selected:
Matt says
Hi Diane,
First thanks for this post it is a great help for people like me who do not have much knowledge on VB or macros.
I'm trying to make a script that will extract data from the body of all emails in a folder. I've used your macro and have it working but it only adds one item to my excel sheet even if I select all the items in my folder. I have hundreds of emails I want to get data from and put into the sheet. What am I missing to run my macro on all items selected?
Diane Poremsky says
This part: Sub CopyToExcel(olItem As Outlook.MailItem) means it's called from a rule as messages arrive. I'm assuming you changed that so it works with selected items or folders and are having a problem with the loop.
You need to loop through all emails. You can use a
For Each obj In objItems
' do whatever
Next
to loop.
I have sample code here - https://www.slipstick.com/developer/code-samples/working-items-folder-selected-items/ - showing how to use that in a simple macro.
Carlos says
Hello Diane, first of all thanks a lot for your posts, they are so useful.
Currently, I'm trying to make a script to send the body message of the incoming emails to an Excel file (as your sample code). I'm using the following line that get the email selected in the Outlook Window.
olItem = Application.ActiveExplorer().Selection(1)
I'd like to know if is there any way to get the body message of the incoming message that comply the condition of the rule, or get the body messages from existing emails that comply that condition (not the selected).
Thanks,
Diane Poremsky says
it's a run a script rule, so it should work as written on my page. If you want to work with selected messages, you'd need to edit the macro to look for the selection. if you want the entire body sent to excel, remove the regex stuff between
sText = olItem.Body and xlSheet.Range("B" & rCount) = vText
to get the body, you'd use something like
xlSheet.Range("B" & rCount) = sText
Alex says
Thanks a lot Diane. Currently if the file is open and there are any changes in the file I've got a message that the file "is already open. Reopening will cause any changes you made to be discarded. Do yo want to repoen?". I wonder if it is possible to handle this situation in some way. The problem is that if thereis an error then Outlook stops running the rule and I have to restart it.
Diane Poremsky says
In that case, I'd have the error check do a save and reopen it. Unfortunately, I don't know what code you'll need to do that.
Foxy says
Hi Diane,
Is it possible to keep the macro running even if the file is opened or Excel itself is running? I managed to customise the code to my situation but it fails to work in both cases.
Diane Poremsky says
It should detect if outlook is running and use that instance. When Excel has a lock on the file, then no, it can't override the lock (and it always locks the files).
These lines check to see if its open and if so, use the open instance, else open it:
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If