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
Reply With Quote
Bookmarks