Export outlook emails to Excel code Error

[jamilm]

Dear Gurus,

i have the following code which was working before and don't know what happen now my debugger stops at Set rep = itm

any help will be appreciated. thanks.


Sub ExportfromoutlooktoExcel()



'On Error GoTo ErrorHandler



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 i As Integer

Dim j As Integer

Dim lngCount As Long

Dim msg As Outlook.MailItem

Dim rep As Outlook.ReportItem

Dim nms As Outlook.NameSpace

Dim fld As Outlook.MAPIFolder

'Must declare as Object because folders may contain different

'types of items

Dim itm As Object

Dim strTitle As String

Dim strPrompt As String

Dim Proceed



Dim fYear, rYear, iMonth As Integer

Dim rMonth As String





Set appExcel = CreateObject("Excel.Application")

Workbooks.Add

Set wkb = appExcel.ActiveWorkbook

Set wks = wkb.Sheets(1)

wks.Activate

appExcel.Application.Visible = True

Sheets("Sheet1").Select

Sheets("Sheet1").Name = "Email"





'Adjust i (row number) to be 1 less than the number of the first body row

i = 1

j = 1



'Create Header Row



Set rng = wks.Cells(i, j)

rng.Value = "Subject"

j = j + 1



Set rng = wks.Cells(i, j)

rng.Value = "Body"

j = j + 1



Set rng = wks.Cells(i, j)

rng.Value = "FromName"

j = j + 1



Set rng = wks.Cells(i, j)

rng.Value = "ToName"

j = j + 1



Set rng = wks.Cells(i, j)

rng.Value = "Importance"

j = j + 1



Set rng = wks.Cells(i, j)

rng.Value = "Sensitivity"



Set rng = wks.Cells(i, j)

rng.Value = "Action Date"



Proceed = MsgBox("Export for Misc Test?", vbYesNo, "Misc Test?")



If Proceed = 7 Then



''Calculate the fiscal year

If Month(Date) = 12 Then

fYear = Year(Date) + 1

Else

fYear = Year(Date)

End If



'Calculate the report calendar year and report month

If Month(Date) = 1 Then

rYear = Year(Date) - 1

iMonth = 12

Else

rYear = Year(Date)

iMonth = Month(Date) - 1

End If



If iMonth < 10 Then

rMonth = "0" & iMonth

Else

rMonth = iMonth

End If



ActiveWorkbook.SaveAs "C:\Users\jamilm\Downloads\FY" & fYear & "\" & rMonth & "." & rYear, 51


Else



appExcel.DisplayAlerts = False

ActiveWorkbook.SaveAs "C:\Users\jamilm\Downloads\misc.xlsx"

appExcel.DisplayAlerts = True



End If





'Let user select a folder to export

Set nms = Application.GetNamespace("MAPI")

Set fld = nms.PickFolder

If fld Is Nothing Then

GoTo ErrorHandlerExit

End If



'Test whether selected folder contains mail messages

If fld.DefaultItemType <> olMailItem Then

MsgBox "Folder does not contain mail messages"

GoTo ErrorHandlerExit

End If



lngCount = fld.Items.Count



If lngCount = 0 Then

MsgBox "No messages to export"

GoTo ErrorHandlerExit

End If







'Iterate through items in the folder, and export a few fields

'from each item to a row in the worksheet

For Each itm In fld.Items

If itm.Class = olMail Then



Set msg = itm

'i is the row number

i = i + 1

'j is the column number

j = 1



Set rng = wks.Cells(i, j)

If msg.Subject <> "" Then rng.Value = msg.Subject

j = j + 1



Set rng = wks.Cells(i, j)

If msg.Body <> "" Then rng.Value = msg.Body

j = j + 1



Set rng = wks.Cells(i, j)

If msg.SenderName <> "" Then rng.Value = msg.SenderName

j = j + 1



Set rng = wks.Cells(i, j)

If msg.To <> "" Then rng.Value = msg.To

j = j + 1



Set rng = wks.Cells(i, j)

rng.Value = msg.Importance

j = j + 1



Set rng = wks.Cells(i, j)

rng.Value = msg.Sensitivity



Set rng = wks.Cells(i, j)

If msg.To <> "" Then rng.Value = msg.ReceivedTime

j = j + 1



Else



Set rep = itm

'i is the row number

i = i + 1

'j is the column number

j = 1



Set rng = wks.Cells(i, j)

If rep.Subject <> "" Then rng.Value = rep.Subject

j = j + 1



Set rng = wks.Cells(i, j)

If rep.Body <> "" Then rng.Value = rep.Body

j = j + 3



Set rng = wks.Cells(i, j)

rng.Value = msg.Importance

j = j + 1



Set rng = wks.Cells(i, j)

rng.Value = msg.Sensitivity



End If

Next itm





Range("B:B").Select

Selection.WrapText = False



ActiveWorkbook.Save

ActiveWorkbook.Close

appExcel.Quit



Set appExcel = Nothing

Set wkb = Nothing

Set wks = Nothing

Set rng = Nothing

Set msg = Nothing

Set rep = Nothing

Set nms = Nothing

Set fld = Nothing

Set itm = Nothing



ErrorHandlerExit:

Exit Sub



ErrorHandler:

If Err.Number = 429 Then

'Application object is not set by GetObject; use CreateObject instead

If appExcel Is Nothing Then

Set appExcel = CreateObject("Excel.Application")

Resume Next

End If

Else

MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description



Resume ErrorHandlerExit

End If



End Sub

[Excel Fox]

One issue may be that your inbox may contain other items apart from MailItem and ReportItem (and that may be why you started to get error recently in a code that was working fine before). Run the code, and find out on which item the error occurs. That may give you a clue as to what other item it is.

You may also want to check the class property of the item to ensure it is one of MailItem or ReportItem

[jamilm]

One issue may be that your inbox may contain other items apart from MailItem and ReportItem (and that may be why you started to get error recently in a code that was working fine before). Run the code, and find out on which item the error occurs. That may give you a clue as to what other item it is.

You may also want to check the class property of the item to ensure it is one of MailItem or ReportItem


i could not figure out the problem, i tried all methods. but finally i found another code from a thread of excel community which works, except for the part that
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.Body this extracts long message, i just want the first 30 char of the body message to be excerpted not all. besides, if i could also excerpt the other information such flag status and category. i do not know how to put addtional code into the code below, to get the flag status and category also.

any help will be appreciated.




Sub ExportToExcelV2()
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 FolderSelected As Outlook.MAPIFolder
Dim varSender As String
Dim itm As Object
' strSheet = "OutlookItems.xlsx"
' strPath = "C:\Users\jamilm\Downloads"
'strSheet = strPath & strSheet
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Application.Visible = True
strSheet = appExcel.GetOpenFilename("Excel Files(*.xl*),*.xl*", 1, "Select Excel File", "Select", False)
appExcel.Workbooks.Open strSheet
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Do
Set FolderSelected = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If FolderSelected Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf FolderSelected.DefaultItemType <> olMailItem Then
MsgBox "These are not Mail Items", vbOKOnly, "Error"
Exit Sub
ElseIf FolderSelected.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Copy field items in mail folder.

intRowCounter = 1
colidx = 1
wks.Cells(intRowCounter, colidx) = "To": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "From": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Subject": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Body": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Received": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Folder": colidx = colidx + 1
intRowCounter = wks.UsedRange.Rows.Count
For Each itm In FolderSelected.Items
intColumnCounter = 1
If TypeOf itm Is MailItem Then
Set msg = itm
intRowCounter = intRowCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.To
varSender = msg.SenderEmailAddress
'================================================= ===========
If InStr(1, msg.SenderEmailAddress, "501288010", vbTextCompare) > 0 Then
varSender = "Todd Curphey"
Else
varSender = msg.SenderEmailAddress
End If
If InStr(1, msg.SenderEmailAddress, "CN=RECIPIENTS/CN=", vbTextCompare) > 0 Then
varSender = "SSO: " & Right(msg.SenderEmailAddress, 9)
Else
varSender = msg.SenderEmailAddress
varSender = msg.SenderName
End If
'================================================= ===========
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = varSender
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.ReceivedTime
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = FolderSelected.Name
End If 'TypeOf
Next itm
DoEvents
Loop
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set FolderSelected = Nothing
Set itm = Nothing
Exit Sub

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