Export outlook email with subject line to Excel - need to modify to add required lines

Hi

I got this VBA script working with Outlook 2010.
This script exports a email with a given subject line ("ABC Contact") with folder selected in outlook at run time and add all the contents of email body to Excel.

I need help to change it so that I can do the below;

1. I want to hard code the outlook folder to say "XYXmail" so that it does not prompt & select this folder always.
2. I need to add only specified 3 lines which is always starts with the with the below text.
A. Name :
B. Tel :
C. Email :

Can someone help to change the below code to get the above 2?

Thanks in advance.

Sub ExportToExcel()

On Error GoTo ErrHandler

Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim workbookFile As String
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object

'Folder path and file name of an existing Excel workbook

workbookFile = "C:\Temp\OutlookItems.xlsx"

'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder

'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
End If

'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
Set wkb = appExcel.Workbooks.Open(workbookFile)
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
Set rng = wks.Range("A1")

'Copy field items in mail folder.

For Each itm In fld.Items
If itm.Class = Outlook.OlObjectClass.olMail Then
Set msg = itm
If InStr(msg.Subject, "ABC Contact") > 0 And DateDiff("d", msg.SentOn, Now) <= 7 Then
rng.Offset(0, 0).Value = msg.To
rng.Offset(0, 1).Value = msg.SenderEmailAddress
rng.Offset(0, 2).Value = msg.Subject
rng.Offset(0, 3).Value = msg.SentOn
rng.Offset(0, 4).Value = msg.Body
Set rng = rng.Offset(1, 0)
End If
End If
Next

Set appExcel = Nothing

Exit Sub

ErrHandler:
If Err.Number = 1004 Then
MsgBox workbookFile & " doesn't exist", vbOKOnly, _
"Error"
Else
MsgBox "Error number: " & Err.Number & vbNewLine & _
"Description: " & Err.Description, vbOKOnly, "Error"
End If

End Sub

Mathew

1.)
Change this...
Set fld = nms.PickFolder
To something like this. Adjust the folder names to suit.
Set fld = nms.Folders("Personal Folders").Folders("XYXmail")

2.) I don't follow. Add three lines from where to where?

Hi AlphaFrog,

Thanks for the reply. It fixed the 1st one.

For the 2nd one, I need to extract on three lines from the email body. Current VBA code extracts all the body into Excel.

I have the below in the body of email - all the emails in this folder - "XYZmail".

Can you please help me to modify the VBA code to get this up & to save the Excel sheet at the end?

Name : Martin Moor
Tel : 6788 9999
Email : [email protected]

I want Excel sheet to put these 2 3 columns but same raw, like below

Martin Moor | 6788 9999 | [email protected]
...
..

Thanks in advance.

Mathew

Hi AlphaFrog,

I get a "Compiler Error: variable not defined" and it highlights the line "strBody = msg.Body". I tried to fix bit, it did not help so far.

Can you please let me know how to fix it?

It hope with this, it should be fine.

Thanks in advance.

Mathew

You have Option Explicit invoked at the top of your module which means you have to explicitly declare all the variables.

Put...
Dim strBody as String
...at the top of your macro with the other Dim statements.
You'll have to declare all the other str variables as well.

Hi AlphaFrog,

Thanks. It worked straight away. All sorted out & got it up.

One last thing if you can help me.

When I run it, it opened the Excel file with the proper contents from outlook. Is it possible to save the Excel file & close it as I check that file later on.
Is it possible with an few additional coding to this?

Thanks again

Mathew

Next
wkb.Close SaveChanges:=True
Set appExcel = Nothing

Exit Sub

Hi AlphaFrog,

Thanks. All good - working well as expected. Thank you one again for all your time to check, reply etc.

I have started exploring ways to learn more on VB and experiment with few more modules to perform more tasks from outlook.

Mathew