Compile Error: Next without For - excel

I am trying to export all data related to a specific folder in my Outlook 2010 to Excel. I need the To, From, Body, All date fields, Has Attachement, etc.. Is there a way where I can include all the fields without defining field by field?
When I run the below code, I have a Compile Error: Next without For.
I believe all the IFs are closed.
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 = "C:\"
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
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Body
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.ReceivedTime
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

It is not the problem of For/Next Loop.
Change the line
ErrHandler: If Err.Number = 1004 Then
to
ErrHandler:
If Err.Number = 1004 Then
TIP: Always indent your code :) You might also want to see this (point 4)?
EDIT: See Point 6 in the above link as well :) To illustrate that in your code, see this part
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
This can be also written as
LetsContinue:
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
Resume LetsContinue
End Sub
Another example
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(strSheet)
Set wks = wkb.Sheets(1)
wks.Activate
You don't need to use Exit Sub so many times
You can put the rest of the code in the Else part of the IF
In fact DO NOT use Exit Sub at all in your code. Reason being, your code will exit the sub without destroying and cleaning up the objects that you created. Exit the procedure gracefully :)
FOLLOWUP
Try this code. (UNTESTED)
Sub ExportToExcel()
On Error GoTo ErrHandler
'~~> Excel Objects / Variables
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim strSheet As String, strPath As String
Dim intRowCounter As Long, intColumnCounter As Long
'~~> Outlook Objects
Dim msg As Outlook.MailItem
Dim nms As Outlook.Namespace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
strSheet = "OutlookItems.xls"
strPath = "C:\"
strSheet = strPath & strSheet
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Else
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
Set wkb = appExcel.Workbooks.Open(strSheet)
Set wks = wkb.Sheets(1)
appExcel.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
Set msg = itm
With wks
intRowCounter = intRowCounter + 1
.Cells(intRowCounter, intColumnCounter) = msg.To
intColumnCounter = intColumnCounter + 1
.Cells(intRowCounter, intColumnCounter) = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
.Cells(intRowCounter, intColumnCounter) = msg.Subject
intColumnCounter = intColumnCounter + 1
.Cells(intRowCounter, intColumnCounter) = msg.Body
intColumnCounter = intColumnCounter + 1
.Cells(intRowCounter, intColumnCounter) = msg.SentOn
intColumnCounter = intColumnCounter + 1
.Cells(intRowCounter, intColumnCounter) = msg.ReceivedTime
End With
Next itm
End If
LetsContinue:
Set appExcel = Nothing
Set wkb = Nothing
Set wks = 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 "Error Number: " & Err.Number & vbNewLine & _
"Error Description: " & Err.Description, vbOKOnly, "Error"
End If
Resume LetsContinue
End Sub

Assuming your code looks like what you pasted, the reason you are getting the error is this line:
'Copy field items in mail folder. For Each itm In fld.Items
Notice that the for part of your loop is part of your comment?
Siddharth gave you a lot of good tips to help avoid these kind of problems, but to get your code to compile just replace the line I showed you with this:
'Copy field items in mail folder.
For Each itm In fld.Items
You also commented out another line:
'Select export folder Set nms = Application.GetNamespace("MAPI")
Should be:
'Select export folder
Set nms = Application.GetNamespace("MAPI")

Related

Method 'Rows' Of Object '_Global' Failed [duplicate]

I am new to VBA as I have just started learning it.
Right now I'm facing a problem in exporting the message body from outlook to excel. The funny thing is when i run the first time, it works. But when when i run the second time, the error message as stated in my title appears.
I clicked on the debug and it highlighted this code: "offsetRow = Cells(Rows.Count, 1).End(xlUp).Row"
I have tried various way like selecting the worksheet that I wanted to paste the data into it but to no avail. Therefore, I hope the experts here can assist me in debugging the code. Also feel free to feedback on my coding if I have done any redundancy that will slow my computer.
FYI, this is for my work so that I can export out the email contents into excel. Thanks in advance.
Sub ExportToExcel()
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
Dim masterData() As String
Dim subData() As String
Dim i As Integer
Dim offsetRow As Long
strSheet = "For fun.xlsx"
strPath = "C:\Users\XXXXX\Desktop\New folder\"
strSheet = strPath & strSheet
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "Thank you for using this service.", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "Please select the correct folder.", 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("Sheet1")
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
Set msg = itm
masterData = Split(msg.Body, vbCrLf) 'Seperate according to lines
For i = 0 To UBound(masterData)
If masterData(i) = "" Then
'Do nothing
Else
'do the split here
subData = Split(masterData(i), vbTab)
wks.Activate
offsetRow = Cells(Rows.Count, 1).End(xlUp).Row 'This is where the error appears
If i = 0 Then
intRowCounter = i + offsetRow + 1
Else
intRowCounter = i + offsetRow
End If
For intColumnCounter = 0 To UBound(subData)
Set rng = wks.Cells(intRowCounter, intColumnCounter + 1)
rng.Value = subData(intColumnCounter)
Next intColumnCounter
End If
Next i
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
End Sub
Your problem is because you don't qualify the Excel range references
Change
offsetRow = Cells(Rows.Count, 1).End(xlUp).Row 'This is where the error appears
To
offsetRow = wks.Cells(wks.Rows.Count, 1).End(-4162).Row
BTW there are a lot of optimisations that can be done to this code
I changed the:
offsetRow = Cells(Rows.Count, 1).End(xlUp).Row
into
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
and it works now.

Create dynamic Excel column from outlook email

Everyday I receive emails like this
ID | Name | Price | QTY | Valid
1 | ABC | 100.50 | 5 | Y
2 | XYZF | 28.34 | 8 | Y
I then copy the content of my email to an excel spreadsheet that I have.
Now what I want to achieve is run a Macro that will read this email and
Create the columns so ID, Name, Price, QTY and Valid
apply the valid values under the right column.
Is this achievable?
From my limited knowledge I have a macro which extracts the whole outlook message but how do I make them into columns and then apply the correct values to correct columns?
Macro
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 = "test.xlsx"
strPath = "C:\test\"
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
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.ReceivedTime
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
Email example
You can delete the lines starting with Set appExcel = Nothing ending with Set itm = Nothing. They are useless, as far as at the end of the "macro", the routine variables are set to Nothing anyhow.
It is a good idea not to use Integer in VBA - Why Use Integer Instead of Long?
This line Set nms = Application.GetNamespace("MAPI") could be written like this, to make the code a bit more robust: Set nms = Outlook.Application.GetNamespace("MAPI")
At the end, your question is more like "how can I extract a string from this":
ID | Name | Price | QTY | Valid
1 | ABC | 100.50 | 5 | Y
2 | XYZF | 28.34 | 8 | Y
to some Excel table. To get the corresponding string, you have to use the .Body. See yourself, changing the loop:
For Each itm In fld.Items
lines = Split(itm.Body, vbCrLf)
For Each line In lines
If Len(line) - Len(Replace(line, "|", "")) > 3 Then
Cells(Row, Column) = Split(line, "|")(0)
Cells(Row, Column + 1) = Split(line, "|")(1)
Cells(Row, Column + 2) = Split(line, "|")(2)
Cells(Row, Column + 3) = Split(line, "|")(3)
End If
Next
Next itm
Once you have 4 or more | per line, then you do Split(line,"|") and you pass each one of the elements of the array to the corresponding column.

Export Outlook email data to macro enabled Excel workbook

I have code in Outlook to export data, from emails in a selected folder, to an Excel Workbook.
In that workbook I have VBA code to parse the data (the subject line for now, eventually the body).
When I export from Outlook to a ".xlsx" file everything looks great.
When I export to my ".xlsm" file it adds columns with information that does not align with the correct imported information.
Ex: Column A & B are correct, A is the CreationTime, B is the full SubjectLine
Column C, D, E, etc. will be random parsed bits of subject lines.
Are the macros in the Excel workbook running when the export to Excel is happening?
If so, how can I prevent that?
My Outlook code:
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
'Opens the Workbook and Sheet to paste in
strSheet = "Tester.xlsx"
strPath = "G:\Jason\"
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.CreationTime
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 <> 0 Then
MsgBox strSheet & " doesn't exist", 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
Parsing code in Excel:
Sub SplitSubjectLine()
Dim text As String
Dim i As Integer
Dim y As Integer
Dim LastRow As Long
Dim name As Variant
ReDim name(3)
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For y = 1 To LastRow
Cells(y, 2).Select
text = ActiveCell.Value
name = Split(text, ",")
For i = 0 To UBound(name)
Cells(y, i + 2).Value = name(i)
Next i
Next
End Sub
You need to wrap your actions in Excel with :
appExcel.EnableEvents = False (before your actions in Excel) and
appExcel.EnableEvents = True when you are done in Excel
Pseudo code :
''Start of your sub
Set appExcel = CreateObject("Excel.Application")
appExcel.EnableEvents = False
''Your actions in Excel
appExcel.EnableEvents = True
''End of your sub

VBA MACRO - Export Email Address To Excel

I have a VBA code here that export email addresses of a chosen subfolder to an Excel file. My problem is that, it only works to only one of my folders.
When I try using this macro to other folders, I'm getting a "Run Time Error 13 TYPE MISMATCH" error. I really don't have an idea why I am getting this error. I hope someone could help me detect where the problem came from.
Here's my code:
Sub ExportToExcel()
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.xlsx"
strPath = "C:\Users\Gabriel.Alejandro\Desktop\"
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.
'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 'The part where I am getting the ERROR
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
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
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
You assume every itm is a mailitem.
You could skip an item if it is not a mailitem:
For Each itm In fld.items
intColumnCounter = 1
If itm.Class = olMail Then
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
Else
Debug.Print " Item is not a mailitem."
End If
Next itm
You could instead bypass errors if the item does not have the properties you want.
For Each itm In fld.items
intColumnCounter = 1
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
On Error Resume Next
rng.Value = itm.To
On Error GoTo 0
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
On Error Resume Next
rng.Value = itm.senderemailaddress
On Error GoTo 0
Next itm

Type mismatch Outlook.MAPIFolder and Object (Error 13) [duplicate]

This question already has answers here:
Using Outlook VBA to forward Emails, but want exclude appointments
(2 answers)
Closed 8 years ago.
I never played with VBA before. This script below is supposed to save all email details in an Outlook folder onto an Excel spreadsheet.
I'm getting error 13 when I execute Set msg = itm. The value of itm at break time corresponds to a meeting invitation, so not your ordinary email. Could that be the problem? If so, how do I tell VBA to ignore anything that's not a plain email?
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 = Environ("UserProfile")
strSheet = strPath & "\Downloads\" & 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
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.ReceivedTime
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"
ElseIf Err.Number = 13 Then
MsgBox Err.Number & ": Type mismatch", 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
If you only want to process MailItem objects, check the Class property - all Outlook Object Model objects implement it. It will be olMail (= 43) for the MailItem objects:
If itm.Class = 43 Then 'olMail
Set msg = itm
...

Resources