Verteilerliste aus Outlook auslesen

[Marko1993]

Hallo liebe Commuity,

gibt es mittels VBA eine Möglichkeit eine zentrale Verteilerliste aus dem adress in Outlook auszulesen und Geschlecht, Nachname und die E-Mailadresse in einer Tabelle darzustellen ? Ich möchte einen Serienbrief erstellen und brauche hierfür die Kontaktliste.

Für die Antworten bedanke ich mich bereits im Voraus.

[Flotter Feger]

Hallo,

ich hab in einem Adressbuch noch nie eine Spalte für das Geschlecht der User gesehen.

Demnach muss die Antwort ... Nein ... lauten.

Wo eventuell ein "Quasi-Geschlecht" erfasst werden kann, ist in den 'Eigenen Kontakten' ... da kann ... muss aber nicht ... die Anredeform ausgewählt werden.
Das ist es aber auch schon.

[EasY]

Hi,

wieso nutzt du nicht die Exportieren-Funktion von Outlook. Damit kannst du dir eine individuelle CSV-Datei erstellen lassen, die du dann in Excel weiterverarbeiten kannst.

Gruß

[Marko1993]

Es geht nicht um das Geschlecht, sondern um die Anrede (also Mann oder Frau), sorry für das Versehen.

Es handelt sich bei der Verteilerliste nicht um eine eigene Liste in meinen Kontakten sondern um eine zentrale Verteilerliste in dem Adressbuch, gepflegt von meinem Unternehmen.

[schauan]

Hallöchen,

ich hab mir vor Jahren mal was aus verschiedenen Seiten zusammengestellt und angepasst, dabei ist das rausgekommen.
Die Sache ist aber nicht so einfach. Zum einen brauchst Du die "internen" Gruppennamen der Verteilergruppen.

Hier in diesen beiden Zeilen trägst Du Eure Daten ein:
Const strDomain = "//MeineDomain"
Const strUGroup = "Interne Gruppenbezeichnung"

Zusätzlich musst Du auch ein paar Firmendaten aus dem AD ermitteln - da kannst Du aus den SysInternals von MS den AD-Explorer verwenden.
(siehe z.B. beim strContainer die ganzen Firmen...)

Alternativ kannst Du mal eine E-Mail mit den Adressen in der Adresszeile erstellen. Die kannst Du kopieren und im Excel einfügen. Anschließend schreibst Du die anderen Daten dazu. Wenn in Deiner Firma die E-Mail-Adresse vorname.nachname@firma... ist, kannst Du das per Formel ermitteln und müsstest nur noch Herr oder Frau ergänzen.
Das könnte deutlich schneller gehen als das Makro bei Dir zum Laufen zu bekommen.

Code:

Option Explicit
Sub Members()
Dim strMember, strDNSDomain, strContainer
Dim objGroup, objRootDse, oUser
Dim arrMemberOf, strList, arrGroup
Dim iCnt&, iCnt2&
Dim strUGroup$, strSheet$
Const strDomain = "//MeineDomain"
Const strUGroup = "Interne Gruppenbezeichnung"
Const E_ADS_PROPERTY_NOT_FOUND = &H8000500D
With Sheets("Verteiler") 'hier stehen die Verteilergruppen, bei mir ab K11
  For iCnt2 = 11 To .Cells(Rows.Count, 11).End(xlUp).Row
    strUGroup = .Cells(iCnt2, 11).Value
    strSheet = strUGroup
    If sheetExist(strSheet) = 0 Then
      Sheets(strSheet).Activate
      Cells.Clear
    Else
      Sheets.Add
      ActiveSheet.Name = strSheet
    End If
    Columns(2).ColumnWidth = 40
    Columns(3).ColumnWidth = 12
    ' Bind to Active Directory'
    strContainer = "CN=" & strUGroup & ",OU=DistributionLists,OU=Firmen-ID,OU=Firmen-Standort,OU=Firmen-OU,OU=Domain Resources, "
    Set objRootDse = GetObject("LDAP://RootDSE")
    strDNSDomain = objRootDse.get("DefaultNamingContext")
    ' Organisationseinheit, in der die Kontakte erzeugt werden sollen
    On Error GoTo weiter
    Set objGroup = GetObject("LDAP://" & strContainer & strDNSDomain)
    objGroup.Filter = Array("user")
    objGroup.GetInfo
    arrMemberOf = objGroup.GetEx("member")
    
    iCnt = 1
    Cells(iCnt, 1) = strUGroup
    For Each strMember In arrMemberOf
       iCnt = iCnt + 1
       strMember = Mid(strMember, 4, 330)
       arrGroup = Split(strMember, ",")
       If UCase(arrGroup(1)) = "OU=GROUPS" Then
       Cells(iCnt, 1) = arrGroup(0)
       Else
       Set oUser = GetObject("LDAP:" & strDomain & "/CN=" & strMember)
       Cells(iCnt, 1) = arrGroup(0)
       Cells(iCnt, 2) = oUser.FullName
       Cells(iCnt, 3) = oUser.department
       End If
    Next
weiter:
  Next
End With

End Sub

'oUser Attribute
'Telefon = (telephoneNumber)
'andere Telefone = (otherTelephone)
'oder = (homePhone)
'Abteilung = (department)
'Fax = (otherFacsimileTelephoneNumber)
'anmeldename = (sAMAccountName)
'vorname = (givenName)
'nachname = (sn)
'mail adresse = (mail)

Function sheetExist(ByVal strName As String) As Long
On Error Resume Next
With Sheets("A"): End With
sheetExist = Err.Number
End Function