Solved: Export senders email address and subject line to Excel

[SDave]

Does anyone know of a vba code that will enable me to export the senders email address and subject line from a particular folder to excel?!

I'm currently using Outlook 2002.

I have tried incorporating the following code, however to no avail:


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 strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object

strSheet = "OutlookItems.xls"
strPath = "P:\Group Reward\Team\Sam\Outlook Items"
strSheet = strPath & strSheet
Debug.Print strSheet
'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")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.To
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject

Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, _
"Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, _
"Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub


Any help would be much appreciated.

Thanks.

[JKwan]

Can you tell me what happens when you run the code? I ran it and I got the Name and subject from it.

[SDave]

I keep receiving a compile error on the following line:


Dim appExcel As Excel.Application


User defined type - not defined.

[SDave]

Problem solved. I failed to select the MS Excel object from the reference listing. Lol!!!

Nevertheless JKwan, I appreciate your help.

[JP2112]

You might consider adding a function that verifies that the path and filename exist, before attempting to open the workbook.

Also, if you're planning on running this code more than once, your code as written will overwrite the existing data on the worksheet.

Turning off screen updating might make the code run a bit faster:


appExcel.ScreenUpdating = False

[sassora]

Problem solved. I failed to select the MS Excel object from the reference listing. Lol!!!

Nevertheless JKwan, I appreciate your help.


I am getting the same error, how would I do the same?

ps. I have outlook 2003

[JKwan]

I am getting the same error, how would I do the same?

ps. I have outlook 2003

Well, did you add a reference to your code?
In Outlook - Tools - Reference and select "Microsoft Excel"

[sassora]

Excellent, thanks