Emailadressen exportieren

Absender exportieren

Das Makro exportiert die Emailadressen der Absender in eine Textdatei. Der Name der Datei steht oben in der Konstante 'SenderFile'. Diesen Wert können Sie anpassen, das angegebene Verzeichnis muss bereits existieren. Wenn Sie das Makro mehrfach ausführen, werden die Adressen an die bestehende Datei angehängt.

Wählen Sie im Outlookordner eine oder mehrere Emails aus und drücken Sie dann alt+f8, um das Makro zu starten.

Wenn Sie beide Beispiele verwenden wollen, kopieren Sie die Funktion 'ShellExecute' nur einmal (weil es in einem Modul keine zwei gleichnamige Funktionen geben darf), oder fügen Sie die Beispiele in zwei verschiedene Module ein (Klick auf Einfügen/Modul).

  So fügen Sie Makros in Outlook ein

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

Empfänger exportieren

Dieses Beispiel entspricht dem ersten, nur dass hier die Empfängeradressen exportiert werden.

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