Outlook Automation
DESCRIPTION:
To export emails to ExcelSheet by using Outlook macro and Excel macro. Basically, the logic of the codes of the two are similar. The only major differences is using different references. When you run macro in outlook, you need to Excel application references. On the other hand, if you run macro in Excel, then you need to outlook references.
1. Make sure macro security setting is set properly.
File -> Options -> Trust Center -> Click “Trust Center Settings” -> macro setting -> Check “Enable all macros”
2. Add Developer tab on outlook menu
File -> Options -> customize ribbon -> check “Developer” mini tabs on the right.
3. Install macro on Outlook
a. Download “ExportToExcel.txt” or copy the code from the code window below, paste and save it as “ExportToExcel.bas”
b. Go to macro editor mode by pressing alt + F11 and import the “ExportToExcel.bas”. File -> import file -> Browse and select the file you just download
4. Add reference: Tools-> References
->“Microsoft Excel 16.0 Object Library”
-> “Microsoft Scripting Runtime”
5. Add macro icon to outlook toolbar
File -> Options -> customize ribbon -> click “New Tab”
Once New Tab (Custom) created, click “Rename” to rename new tab to meaningful name. Example: Macro.
Rename tab group to whatever group name you want and choose whatever icon you want. Example: Custom Macro Group
Insert macro to the Custom Macro Group. Under “Choose commands from”, select “Macros”, select “Project1.ExportToExcel” and click Add button
Rename Macro to any meaningful name and choose the icon. Select macro and then click “Rename” button
6. Run macro, click “ExportToExcel” icon on outlook toolbar
Outlook Macro
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | Sub ExportToExcel() Dim appExcel As Excel.Application 'Add reference: Tools-> References -> "Microsoft Excel 16.0 Object Library" Dim msg As Outlook.mailItem Dim nms As Outlook.Namespace Dim fld As Outlook.MAPIFolder Dim itm As Object Dim fso As New FileSystemObject Dim wkb As Excel.Workbook Dim wks As Excel.Worksheet Dim rng As Excel.Range Dim strSheet As String Dim strPath As String Dim Rount As Integer Dim intColumnCounter As Integer Dim YesorNo As Integer Dim ErrorTxt As String ErrorTxt = "Reference Set up" Set appExcel = CreateObject("Excel.Application") appExcel.Application.Visible = True strPath = "C:\work" strSheet = strPath & "\OutlookToExcel.xls" If Not fso.FolderExists(strPath) Then MkDir (strPath) End If appExcel.Workbooks.Add.SaveAs strSheet 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 ErrorTxt = ErrorTxt & ", open workbook" appExcel.Workbooks.Open (strSheet) Set wkb = appExcel.ActiveWorkbook Set wks = wkb.Sheets(1) wks.Activate With wks If .Range("A1") = "" Then 'New workbook .Range("A1") = "Received on" .Range("B1").Value = "Sender Email" .Range("C1") = "Subject" .Range("D1") = "Body Text" .Range("A1:E1").Font.Size = 16 .Range("A1:E1").Font.Color = vbYellow .Range("A1:E1").Interior.Color = rgbDarkGreen End If Rount = .Range("A" & .Rows.Count).End(xlUp).Row 'Find last row 'Copy field items in mail folder. ErrorTxt = ", Error in reading email folder" For Each itm In fld.Items Rount = Rount + 1 Set msg = itm .Range("A1" & Rount) = msg.ReceivedTime .Range("B" & Rount) = msg.SenderEmailAddress .Range("C" & Rount) = msg.Subject EmailTxtBody = Replace(msg.Body, vbCrLf, " ") EmailTxtBody = Replace(EmailTxtBody, " ", " ") .Range("D" & Rount) = Left(EmailTxtBody, 30) Next itm .Columns.EntireColumn.AutoFit End With 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: Set appExcel = Nothing If Err.Number = 1004 Then MsgBox strSheet & " doesn't exist", vbOKOnly, "Error" Else MsgBox Err.Number & "; Description: " & vbCrLf & ErrorTxt, 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 |
Excel Macro
To run this from Excel. Add reference: Tools-> References ->“Microsoft outlook 16.0 Object Library”
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | Sub ImportFromOutlook() Dim MyOutlook As Outlook.Application Dim msg As mailItem Dim nms As Namespace Dim fld As MAPIFolder Dim itm As Object Dim fso As New FileSystemObject Dim wkb As Excel.Workbook Dim wks As Excel.Worksheet Dim rng As Excel.Range Dim strSheet As String Dim strPath As String Dim Rount As Integer Dim intColumnCounter As Integer Dim YesorNo As Integer Dim ErrorTxt As String Set MyOutlook = New Outlook.Application Set nms = MyOutlook.GetNamespace("MAPI") Set emailfolder = nms.Folders(3) Set fld = nms.GetDefaultFolder(olFolderInbox).Parent Set fld = nms.GetDefaultFolder(olFolderInbox) ErrorTxt = "Reference Set up" Set MyOutlook = New Outlook.Application strPath = "C:\work" strSheet = strPath & "\OutlookToExcel.xls" If Not fso.FolderExists(strPath) Then MkDir (strPath) End If Workbooks.Add.SaveAs strSheet '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 ErrorTxt = ErrorTxt & ", open workbook" Workbooks.Open (strSheet) Set wkb = ActiveWorkbook Set wks = wkb.Sheets(1) wks.Activate With wks If .Range("A1") = "" Then 'New workbook .Range("A1") = "Received on" .Range("B1").Value = "Sender Email" .Range("C1") = "Subject" .Range("D1") = "Body Text" .Range("A1:E1").Font.Size = 16 .Range("A1:E1").Font.Color = vbYellow .Range("A1:E1").Interior.Color = rgbDarkGreen End If Rount = .Range("A" & .Rows.Count).End(xlUp).Row 'Find last row 'Copy field items in mail folder. ErrorTxt = ", Error in reading email folder" For Each itm In fld.Items Rount = Rount + 1 Set msg = itm .Range("A1" & Rount) = msg.ReceivedTime .Range("B" & Rount) = msg.SenderEmailAddress .Range("C" & Rount) = msg.Subject EmailTxtBody = Replace(msg.Body, vbCrLf, " ") EmailTxtBody = Replace(EmailTxtBody, " ", " ") .Range("D" & Rount) = Left(EmailTxtBody, 30) Next itm .Columns.EntireColumn.AutoFit End With 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: Set appExcel = Nothing If Err.Number = 1004 Then MsgBox strSheet & " doesn't exist", vbOKOnly, "Error" Else MsgBox Err.Number & "; Description: " & vbCrLf & ErrorTxt, 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 |
ImportFromOutlook
ExportToExcel
Ratings: 
(No Ratings Yet)
Loading...