Export Email Addresses

Export Sender

The macro exports the email address of the senders to a text file. See the name of the file at the top in the constant 'SenderFile'. You can change its name, and ensure that the directory already exists. If you run the macro multiple times, the addresses will be appended to the existing file.

Select one or more emails in the Outlook folder, then press alt+f8 to launch the macro.

If you want to use both samples, copy the function 'ShellExecute' only once because it isn´t allowed to have two functions of the same name in one module. Alternatively, add two modules (click Insert/Module), one for each sample (click Insert/Module).

  How to add macros to Outlook

Private Const SenderFile As String = "c:\email addresses\senders.txt"

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Sub ExportSenderAddresses()
  On Error GoTo ERR_HANDLER
  Dim Sel As Outlook.Selection
  Dim Addresses As String
  Dim File As String
  Dim Hnd As Long
  
  Set Sel = Application.ActiveExplorer.Selection
  Addresses = GetSenderAddresses(Sel)
  If Len(Addresses) Then
    Hnd = FreeFile
    Open SenderFile For Append As #Hnd
    Print #Hnd, Addresses;
    Close #Hnd
    ShellExecute 0, "open", SenderFile, "", "", 1
  End If
  
  Exit Sub
ERR_HANDLER:
  If Hnd Then Close #Hnd
  MsgBox Err.Description
End Sub

Private Function GetSenderAddresses(Sel As Outlook.Selection) As String
  Dim b As String
  Dim obj As Object
  Dim i As Long
  
  For i = 1 To Sel.Count
    Set obj = Sel(i)
    If TypeOf obj Is Outlook.MailItem Or _
      TypeOf obj Is Outlook.MeetingItem Then
        b = b & obj.SenderEmailAddress & vbCrLf
    End If
  Next
  
  GetSenderAddresses = b
End Function

Export Recipients

This sample is similar to the first one, except this one exports the addresses of the recipients.

Private Const RecipientFile As String = "c:\email addresses\recipients.txt"

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Sub ExportRecipientAddresses()
  On Error GoTo ERR_HANDLER
  Dim Sel As Outlook.Selection
  Dim Addresses As String
  Dim File As String
  Dim Hnd As Long
  
  Set Sel = Application.ActiveExplorer.Selection
  Addresses = GetRecipienAddresses(Sel)
  If Len(Addresses) Then
    Hnd = FreeFile
    Open RecipientFile For Append As #Hnd
    Print #Hnd, Addresses;
    Close #Hnd
    ShellExecute 0, "open", RecipientFile, "", "", 1
  End If
  
  Exit Sub
ERR_HANDLER:
  If Hnd Then Close #Hnd
  MsgBox Err.Description
End Sub

Private Function GetRecipienAddresses(Sel As Outlook.Selection) As String
  Dim b As String
  Dim obj As Object
  Dim Recipients As Outlook.Recipients
  Dim r As Outlook.Recipient
  Dim i As Long
  
  For i = 1 To Sel.Count
    Set obj = Sel(i)
    If TypeOf obj Is Outlook.MailItem Or _
      TypeOf obj Is Outlook.MeetingItem Then
      Set Recipients = obj.Recipients
      For Each r In Recipients
        b = b & r.Address & vbCrLf
      Next
    End If
  Next
  
  GetRecipienAddresses = b
End Function