Macro to Export Outlook Fields to Excel

Chia sẻ bởi:hands

★★★★★

‹ Run a script rule: Autoreply using a... Reply or ReplyAll with Attachments ›

Quảng cáo

This macro collects the fields from each Outlook message in a selection and writes the values of the fields to an Excel worksheet. It's easily adapted to work with any field and any Outlook item type.

In Excel 2016, rCount is finding the last USED line, not the next blank line. Use rCount = rCount + 1 to move down one line.

[URL='cdn.slipstick.com/images/2014/code-samples/spreadsheet.jpg']cdn.slipstick.com/images/2014/code-samples/spreadsheet-575×93.jpg

Updated November 25 2017 to get all recipient addresses.
Updated October 20 2017 to create a new workbook (user will need to save it). Also added column names and adjusted the column widths.

If you want to run the macro on all messages in the selected folder, [URL='www.slipstick.com/macros/CopyToExcel-selectedfolder.txt']use this file. In addition, it will create the workbook if it doesn't exist and add the columns headers if needed.

An Excel version of this macro is available in [URL='www.slipstick.com/code-samples/CopyOutlookMailtoExcel.xlsm']a workbook template here or [URL='www.slipstick.com/code-samples/CopyMailtoExcel-excel-macro.txt']as a text file here. The workbook code removes hyperlinked URLs from the messages (for easier reading in Excel).

Option Explicit
 Sub CopyToExcel()
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String

Dim currentExplorer As Explorer
 Dim Selection As Selection
 Dim olItem As Outlook.MailItem
 Dim obj As Object
 Dim strColA, strColB, strColC, strColD, strColE As String

' Get Excel set up
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0

'## Open a specific workbook to input the data
'the path of the workbook under the windows user account
'enviro = CStr(Environ("USERPROFILE"))
' strPath = enviro & "Documentstest.xlsx"
'     Set xlWB = xlApp.Workbooks.Open(strPath)
'     Set xlSheet = xlWB.Sheets("Sheet1")
'## End Specific workbook

'## Use New Workbook
Set xlWB = xlApp.Workbooks.Add
Set xlSheet = xlWB.Sheets("Sheet1")
'## end use new workbook

' Add column names
  xlSheet.Range("A1") = "Sender"
  xlSheet.Range("B1") = "Sender address"
  xlSheet.Range("C1") = "Message Body"
  xlSheet.Range("D1") = "Sent To"
  xlSheet.Range("E1") = "Recieved Time"

' Process the message record

On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
  For Each obj In Selection

Set olItem = obj

'collect the fields
    strColA = olItem.SenderName
    strColB = olItem.SenderEmailAddress
    strColC = olItem.Body
    strColD = olItem.To
    strColE = olItem.ReceivedTime

'### Get all recipient addresses
' instead of To names
Dim strRecipients As String
Dim Recipient As Outlook.Recipient
For Each Recipient In olItem.Recipients
 strRecipients = Recipient.Address & "; " & strRecipients
 Next Recipient

strColD = strRecipients
'### end all recipients addresses

'### Get the Exchange address
' if not using Exchange, this block can be removed
 Dim olEU As Outlook.ExchangeUser
 Dim oEDL As Outlook.ExchangeDistributionList
 Dim recip As Outlook.Recipient
 Set recip = Application.Session.CreateRecipient(strColB)

If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
    Select Case recip.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
             strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
     End Select
End If
' ### End Exchange section

'write them in the excel sheet
  xlSheet.Range("A" & rCount) = strColA ' sender name
  xlSheet.Range("B" & rCount) = strColB ' sender address
  xlSheet.Range("C" & rCount) = strColC ' message body
  xlSheet.Range("D" & rCount) = strColD ' sent to
  xlSheet.Range("E" & rCount) = strColE ' recieved time

'Next row
  rCount = rCount + 1
Next
' size the cells
    xlSheet.Columns("A:E").EntireColumn.AutoFit
    xlSheet.Columns("C:C").ColumnWidth = 100
    xlSheet.Columns("D:D").ColumnWidth = 30
    xlSheet.Range("A2").Select
    xlSheet.Columns("A:E").VerticalAlignment = xlTop

xlApp.Visible = True

' to save but not close
'xlWB.Save

' to save and close
'     xlWB.Close 1
'     If bXStarted Then
'         xlApp.Quit
'     End If
' end save and close

Set olItem = Nothing
     Set obj = Nothing
     Set currentExplorer = Nothing
     Set xlSheet = Nothing
     Set xlWB = Nothing
     Set xlApp = Nothing
 End Sub

Automate using an ItemAdd or Run a Script Macro

With a few slight modifications, we can watch a folder for new messages and process new mail as it arrives.

This set of macros needs to go into ThisOutlookSession.

Warning: If too many messages come in at one time, the macro could fail.

If you need to filter the messages that added to the spreadsheet you have two options: use an If statement to exit the macro or convert it to a [URL='www.slipstick.com/outlook/rules/outlooks-rules-and-alerts-run-a-script/']Run a Rule script.

If you use an if Statement, it should be the first line of the bjItems_ItemAdd macro.

Private Sub objItems_ItemAdd(ByVal Item As Object)
If InStr(1, Item.Subject, "Tip") = 0 Then Exit Sub

For a run a script rule, delete Private Sub objItems_ItemAdd(ByVal Item As Object) and all of the lines above it then use this as the macro name and create your rule.
Public Sub ShowMessage(Item As Outlook.MailItem)

Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items

Private Sub Application_Startup()

Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")

'Set the folder and items to watch:
' Use this for a folder in your default data file
Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox)

' to watch a folder in a non-default data file
' seehttps://slipstick.me/qf for GetFolderPath Function
' Set objWatchFolder = GetFolderPath("me@domain.comInbox")

Set objItems = objWatchFolder.Items

Set objWatchFolder = Nothing
End Sub

Private Sub objItems_ItemAdd(ByVal Item As Object)
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String

Dim strColB, strColC, strColD, strColE, strColF As String

' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
 strPath = enviro & "Documentstest.xlsx"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     'Open the workbook to input the data
     Set xlWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlWB.Sheets("Sheet1")
    ' Process the message record

On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

'collect the fields
    strColC = Item.SenderEmailAddress
    strColB = Item.SenderName
    strColD = Item.Body
    strColE = Item.To
    strColF = Item.ReceivedTime

' Get the Exchange address
' if not using Exchange, this block can be removed
 Dim olEU As Outlook.ExchangeUser
 Dim oEDL As Outlook.ExchangeDistributionList
 Dim recip As Outlook.Recipient
 Set recip = Application.session.CreateRecipient(strColC)

If InStr(1, strColC, "/") > 0 Then
' if exchange, get smtp address
     Select Case recip.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
             strColC = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strColC = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strColC = olEU.PrimarySmtpAddress
         End If
     End Select
End If
' End Exchange section

'write them in the excel sheet
  xlSheet.Range("B" & rCount) = strColB
  xlSheet.Range("c" & rCount) = strColC
  xlSheet.Range("d" & rCount) = strColD
  xlSheet.Range("e" & rCount) = strColE
  xlSheet.Range("f" & rCount) = strColF

'Next row
  rCount = rCount + 1

xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If

Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
 End Sub

How to use macros

First: You will need macro security set to low during testing.

To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it's at Tools, Macro Security.

After you test the macro and see that it works, you can either leave macro security set to low or [URL='www.slipstick.com/developer/how-to-use-outlooks-vba-editor/']sign the macro.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

To put the code in a module: