Excel 2013>Outlook 2013>Macro>Check Inbox>Copy Info from Formatted Emails to Excel

[aworthey]

Hello,

I'm trying to write a macro for my project management dashboard in Excel 2013 that would look in my Outlook 2013 Inbox for unread emails and copy information from a consistently formatted message to an Excel worksheet.

I have enabled macros in Outlook. Are there other settings I need to be aware of in Outlook and Excel? I've tried running sample codes, but I always encounter error messages when Dim-ing a variable as Namespace.

I appreciate any help you can offer!!

[aworthey]

I discovered that I needed to change a setting within the VBA editor. I clicked on Tools>References and selected Microsoft Outlook 15.0 Object Library.

It's working now. But now when referencing my default inbox folder I can't seem to detect the emails. I'm utilizing the Items() method, but I don't understand the syntax.

Here's the sample code I'm running:


Sub Button1_Click()

Dim objNS As Outlook.Namespace
Dim objInbox As Outlook.MAPIFolder
Dim objMyFolder As MAPIFolder
Dim objItem As MailItem


Set objNS = Outlook.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objItem = objInbox.Items(1)
Set objMyFolder = objInbox
' assumes your folder is sub of Inbox

For Each objItem In objMyFolder.Items
' test unread
If objItem.Unread Then
' do something

'objItem.Subject
'objItem.Sent
MsgBox ("objItem.Unread")

End If
Next objItem

[aworthey]

Here's the solution I came up with:


Sub Button1_Click()

Dim objNS As Outlook.Namespace
Dim objInbox As Outlook.MAPIFolder
Dim objMyFolder As Outlook.MAPIFolder
Dim objItem As Outlook.MailItem

Set objNS = Outlook.GetNamespace("MAPI")
Set objInbox = objNS.Folders("Applications Engineering").Folders("Inbox")
Set objMyFolder = objInbox
Set objItem = objInbox.Items(1)

For Each objItem In objMyFolder.Items
' test unread
If objItem.UnRead Then

MsgBox (objItem.Body)

End If
Next objItem



End Sub

[aworthey]

Now I need to figure out how to copy specific fields from unread emails to specific cells in a worksheet...

[gmayor]

The code does not need a reference to Outlook if you use the following syntax

Sub Button1_Click()
Dim olApp As Object
Dim objNS As Object
Dim objFolder As Object
Dim objItem As Object
On Error Resume Next
'Get Outlook if it's running
Set olApp = GetObject(, "Outlook.Application")
'Outlook wasn't running, start it from code
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
Set objNS = olApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders("Applications Engineering").Folders("Inbox")

For Each objItem In objFolder.Items
If objItem.UnRead Then
MsgBox (objItem.Body)
End If
Next objItem
lbl_Exit:
Set olApp = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objItem = Nothing
Exit Sub
End Sub


My web page - http://www.gmayor.com/extract_data_from_email.htm explains how to extract different types of data from the message. See also the link at the end of that page where all the work has been done for you.

[aworthey]

Gmayor, Thank you so very much for your help!! I sincerely appreciate it!

[aworthey]

Gmayor,

I'm experimenting with the code on your web page, and I'm encountering an error. Here's your code with a few of my changes:


Option Explicit


Sub CopyToExcel(olItem As MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText As Variant
Dim sText As String
Dim sAddr As String
Dim vAddr As Variant
Dim vItem As Variant
Dim i As Long, j As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strWorkSheetName As String = "Sheet2"
Const strWorkBookName As String = "C:\Users\ko98240\Desktop\Book1.xlsx" 'the path of the workbook
'Use FileExists function to determine the availability of the workbook
If Not FileExists(strWorkBookName) Then Exit Sub
'Get Excel if it is running, or open it if not
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
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(strWorkBookName)
Set xlSheet = xlWB.Sheets("Sheet1")


'Process the message
With olItem
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1


'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Job Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Contact Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Company:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Generator and ATS:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Tank & Enclosure:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Switchgear:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Other:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Revisions:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If


'If InStr(1, vText(i), "Destination City:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("I" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Destination State:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("J" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Destination Zip:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("K" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Vehicle Type:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("L" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Vehicle Year:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("M" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Vehicle Make:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("N" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Vehicle Model:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("O" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Vehicle Condition:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("P" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Comments:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("Q" & rCount) = Trim(vItem(1))
'End If
Next i
xlWB.Save
End With
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub




I'm encountering the error with this line:
If Not FileExists(strWorkBookName) Then Exit Sub

It is a Sub or Function Not Defined error. Any ideas?

Thank you for your help!

[aworthey]

Here's what I actually got to work for my test:


Option Explicit


Sub CopyToExcel(olItem As MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText As Variant
Dim sText As String
Dim sAddr As String
Dim vAddr As Variant
Dim vItem As Variant
Dim i As Long, j As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strWorkSheetName As String = "Sheet2"
Const strWorkBookName As String = "C:\Users\ko98240\Desktop\Book1.xlsm" 'the path of the workbook




'Open the workbook to input the data
Set xlWB = Excel.Workbooks.Open("C:\Users\ko98240\Desktop\Book1.xlsm")
'Set xlWB = xlApp.Workbooks.Open("C:\Users\ko98240\Desktop\Book1.xlsm")
Set xlSheet = xlWB.Sheets("Sheet2")


'Process the message
With olItem
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1


'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Job Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Contact Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Company:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Generator and ATS:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Tank & Enclosure:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Switchgear:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Other:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Revisions:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If


'If InStr(1, vText(i), "Destination City:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("I" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Destination State:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("J" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Destination Zip:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("K" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Vehicle Type:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("L" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Vehicle Year:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("M" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Vehicle Make:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("N" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Vehicle Model:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("O" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Vehicle Condition:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("P" & rCount) = Trim(vItem(1))
'End If


'If InStr(1, vText(i), "Comments:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("Q" & rCount) = Trim(vItem(1))
'End If
Next i
xlWB.Save
End With
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub


I'm running this from within Outlook set up as a rule for incoming emails. Do you have any suggestions for cleaning up the code further?

This is amazing! I appreciate your responding to my post!

[gmayor]

The error you mentioned earlier relates to the fact that you haven't copied the FileExists function to your module.

'Cleaning up the code'? The code on my web site is intended to be run from Outlook, ideally from a rule that processes the messages as they arrive. You appeared to want to run it from a button in Excel to process existing messages in your appropriate inbox folder. In that case it would need some changes. For a start you won't need the call to the FileExists function as the button is presumably in that workbook so it obviously exists. Similarly you won't need to open the workbook as it will be already open. The code will then be something like the following. This is untested as I have not setup a similar environment to that you are using, but it looks about right.



Option Explicit

Sub Button1_Click()
Dim olApp As Object
Dim objNS As Object
Dim objFolder As Object
Dim objItem As Object
On Error Resume Next
'Get Outlook if it's running
Set olApp = GetObject(, "Outlook.Application")
'Outlook wasn't running, start it from code
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
Set objNS = olApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders("Applications Engineering").Folders("Inbox")

For Each objItem In objFolder.Items
If objItem.UnRead Then
sText = objItem.body
CopyToExcel sText
DoEvents
End If
Next objItem
lbl_Exit:
Set olApp = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objItem = Nothing
Exit Sub
End Sub

Sub CopyToExcel(sText As String)
Dim xlWB As Workbook
Dim xlSheet As Worksheet
Dim vText As Variant
Dim sAddr As String
Dim vAddr As Variant
Dim vItem As Variant
Dim i As Long, j As Long
Dim rCount As Long

Const strWorkSheetName As String = "Sheet2"
Set xlWB = ActiveWorkbook
Set xlSheet = xlWB.Sheets(strWorkSheetName)

'Process the message
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1

'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Job Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "Contact Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "Company:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "Generator and ATS:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "Tank & Enclosure:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "Switchgear:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "Other:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "Revisions:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub

[aworthey]

Gmayor,

I really appreciate your willingness to help!!

I finally figured that out--that it was intended to run from within Outlook with a rule. It's working perfectly now...it's amazing that this is even possible!

Thank you so much!