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