Export outlook emails to Excel code Error

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.

Code:

---

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

---

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
http://www.eileenslounge.com/viewtopic.php?f=30&t=41784
http://www.eileenslounge.com/viewtopic.php?p=323966#p323966
http://www.eileenslounge.com/viewtopic.php?p=323959#p323959
http://www.eileenslounge.com/viewtopic.php?p=323960#p323960
http://www.eileenslounge.com/viewtopic.php?p=323894#p323894
http://www.eileenslounge.com/viewtopic.php?p=323843#p323843
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa6BSa173Z
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa6-64Xpgl
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa5ms39yjd
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa5ZXJwRCM
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa4Pr15NUt
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa4I83JelY
https://www.youtube.com/watch?v=C43btudYyzA&lc=Ugyf349Ue6_4umFfNUB4AaABAg. 8mjgPNoTt_HABa3tnAjhZU
https://www.youtube.com/watch?v=C43btudYyzA&lc=Ugyf349Ue6_4umFfNUB4AaABAg. 8mjgPNoTt_HABa3KswxL3c
https://www.youtube.com/watch?v=suUqEo3QWus&lc=UgyBXFxnVWT3pqtdqPx4AaABAg
https://www.youtube.com/watch?v=suUqEo3QWus&lc=Ugi53h84LUm5bHgCoAEC.7-H0Z7-COoGABZFQ8vjEvY
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABZ8N9O-O8p
http://www.eileenslounge.com/viewtopic.php?p=323547#p323547
http://www.eileenslounge.com/viewtopic.php?p=323516#p323516
http://www.eileenslounge.com/viewtopic.php?p=323517#p323517
http://www.eileenslounge.com/viewtopic.php?p=323449#p323449
http://www.eileenslounge.com/viewtopic.php?p=323226#p323226
http://www.eileenslounge.com/viewtopic.php?f=25&t=41702&p=323150#p323150
http://www.eileenslounge.com/viewtopic.php?p=323085#p323085
http://www.eileenslounge.com/viewtopic.php?p=322955#p322955
http://www.eileenslounge.com/viewtopic.php?f=30&t=41659
https://www.youtube.com/watch?v=suUqEo3QWus&lc=Ugi53h84LUm5bHgCoAEC.7-H0Z7-COoGABZFQ8vjEvY
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABZ8N9O-O8p
https://www.youtube.com/watch?v=C43btudYyzA&lc=UgxREWxgx2z2Lza_0st4AaABAg
https://www.youtube.com/watch?v=C43btudYyzA&lc=UgyikSWvlxbWS24NBeR4AaABAg
https://www.youtube.com/watch?v=C43btudYyzA&lc=UgwNiH4hhyrd2UjDK8d4AaABAg
https://www.youtube.com/watch?v=C43btudYyzA&lc=Ugyf349Ue6_4umFfNUB4AaABAg. 8mjgPNoTt_HAAf952WoUti
https://www.youtube.com/watch?v=hz4vb48wzMM&lc=Ugy2N3gvXBNrvWpojqR4AaABAg
http://www.eileenslounge.com/viewtopic.php?p=322462#p322462
http://www.eileenslounge.com/viewtopic.php?p=322356#p322356
http://www.eileenslounge.com/viewtopic.php?p=321984#p321984
https://eileenslounge.com/viewtopic.php?f=30&t=41610
https://eileenslounge.com/viewtopic.php?p=322176#p322176
https://eileenslounge.com/viewtopic.php?p=322238#p322238
https://eileenslounge.com/viewtopic.php?p=322270#p322270
https://eileenslounge.com/viewtopic.php?p=322300#p322300
http://www.eileenslounge.com/viewtopic.php?p=322150#p322150
http://www.eileenslounge.com/viewtopic.php?p=322111#p322111
http://www.eileenslounge.com/viewtopic.php?p=322086#p322086
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

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

Quote:

---

Originally Posted by 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

---

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

Code:

---

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.

Code:

---

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

---