Clever-Excel-Forum

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.

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.

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ß

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.

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

Marko1993

Flotter Feger

EasY

Marko1993

schauan