Anzeige
Archiv - Navigation
1504to1508
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Prüfung in Outlook Adressbuch (global) aus Makro

Prüfung in Outlook Adressbuch (global) aus Makro
15.07.2016 11:41:04
Jörg
Hallo zusammen,
ich bin gerade dabei einen Emailversand aufzusetzen.
Bei diesem sollen im Vorfeld zum Versand ein paar Checks durchlaufen warden (Sind Dateien vorhanden,...)
Zu diesen Checks gehört auch, dass gegen das Outlook Adressbuch (Global von Exchange Server) geprüft werden soll, ob Personen noch vorhanden sind, und damit eine Email bekommen können.
Die Personen stehen in einem Arbeitsblatt in einer Zelle nach folgendem Muster:
Nachname, Vorname; Nachname2, Vorname2; Nachname3, Vorname3
Die Anzahl variiert bei jedem Versand - Wie bekomme ich einen Check der mir als Ausgabe die Namen getrennt ausliefert:
1. vorhandene Einträge in eine Zelle: Nachname, Vorname; Nachname2, Vorname2
2. Nicht vorhandene Einträge in eine zweite Zelle: Nachname3, Vorname3?
Wir haben hier mehrere Tausend Einträge im globalen Adressbuch, so dass das ganze natürlich auch noch "schnell" gehen sollte.
Vielen Dank im Voraus!
Jörg

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Prüfung in Outlook Adressbuch (global) aus Makro
17.07.2016 09:23:52
fcs
Hallo Jörg,
nachfolgend ein Beispiel wie du die Daten in der Zelle mit einem Adressbuch in Outlook abgleichen kannst.
Im Makro musst du die Zell-Adressen anpassen und den Namen des Adressbuchs/der Kontaktliste in Outlook.
Gruß
Franz
Sub Abgleich_Namen_Outlook()
Dim olApp As Object  'As Outlook.Application
Dim olAdrBook As Object  'As Outlook.AddressList
Dim olAdress As Object  'As Outlook.AddressEntry
Dim olContact As Object  'As Outlook.ContactItem
Dim myNamespace As Object  'As Outlook.Namespace
Dim wksData As Worksheet
Dim bolVorhanden As Boolean
Dim arrNamen, intName As Integer, intN_L As Integer, intN_U As Integer
Dim arrNamen_OL(), intOL As Integer
Dim sName As String, sVorname As String, sNameVorname As String
Dim arrV(), intV As Integer
Dim arrNV(), intNV As Integer
Set wksData = ActiveWorkbook.Worksheets("Tabelle1") 'Tabelle mit den Naen in einer Zelle
'Namen aus Zelle einlesen und Ergebnis-Arrays vorbereiten
arrNamen = VBA.Split(wksData.Range("B3").Text, ";")
intN_L = LBound(arrNamen)
intN_U = UBound(arrNamen)
ReDim Preserve arrV(intN_L To intN_U)
ReDim Preserve arrNV(intN_L To intN_U)
intV = intN_L - 1
intNV = intV
'Outlook-Objekte setzen
Set olApp = VBA.CreateObject("Outlook.Application")
Set myNamespace = olApp.GetNamespace("MAPI")
Set olAdrBook = myNamespace.AddressLists("Kontakte")          'Name ggf. anpassen
'Namen aus Outlook-Adressliste in Datenarray einlesen
ReDim Preserve arrNamen_OL(1 To olAdrBook.AddressEntries.Count)
For Each olAdress In olAdrBook.AddressEntries
Set olContact = olAdress.GetContact
sName = olContact.LastName
sVorname = olContact.FirstName
intOL = intOL + 1
arrNamen_OL(intOL) = sName & ", " & sVorname
Next
'Namen mit Liste in Outlook abgleichen
For intName = intN_L To intN_U
bolVorhanden = False
If InStr(arrNamen(intName), ",") > 0 Then
sName = Trim(Split(arrNamen(intName), ",")(0))
sVorname = Trim(Split(arrNamen(intName), ",")(1))
sNameVorname = sName & ", " & sVorname
For intOL = LBound(arrNamen_OL) To UBound(arrNamen_OL)
If arrNamen_OL(intOL) = sNameVorname Then
bolVorhanden = True
Exit For
End If
Next
If bolVorhanden = True Then
intV = intV + 1
arrV(intV) = sNameVorname
Else
intNV = intNV + 1
arrNV(intNV) = sNameVorname
End If
End If
Next
'Ergebnis-Daten in Tabellenblatt eintragen
With wksData
With .Range("B5") 'vorhandene Namen
If intV >= intN_L Then
ReDim Preserve arrV(intN_L To intV)
.Value = VBA.Join(arrV, ";")
Else
.ClearContents
End If
End With
With .Range("B6") 'nicht vorhandene Namen
If intNV >= intN_L Then
ReDim Preserve arrNV(intN_L To intNV)
.Value = VBA.Join(arrNV, ";")
Else
.ClearContents
End If
End With
End With
'Objekt-Variablen zurücksetzen
Set olApp = Nothing: Set myNamespace = Nothing: Set olAdrBook = Nothing
Set olContact = Nothing: Set wksData = Nothing
Erase arrV, arrNV, arrNamen, arrNamen_OL
End Sub

Anzeige
AW: Prüfung in Outlook Adressbuch (global)
18.07.2016 08:55:56
Jörg
Super. Ich habe den Code gleich probiert und entsprechend für mich angepasst. Leider bekomme ich einen Laufzeitfehler 91 "Objektvariable oder With-Blockvariable nicht festgelegt".
Auftreten tut dies laut Debugger hier:
    For Each olAdress In olAdrBook.AddressEntries
Set olContact = olAdress.GetContact
sName = olContact.LastName
sVorname = olContact.FirstName
intOL = intOL + 1
arrNamen_OL(intOL) = sName & ", " & sVorname
Next
und zwar in der Zeile
sName = ol-Contact.LastName
.
So richtig schlau werde ich darauf gerade nicht - davor wird ja alles richtig aufgelöst.
Danke & Gruß
Jörg
Anzeige
AW: Prüfung in Outlook Adressbuch (global)
18.07.2016 09:12:44
Jörg
Ergänzung hierzu:
Beim Debuggen ist nach dem Befehl:
Set olContact = olAdress.GetContact
der Inhalt von olContact angegeben mit "Nothing"
Ich denke, daher müsste der Fehler kommen?
AW: Prüfung in Outlook Adressbuch (global)
18.07.2016 09:53:17
Jörg
Ok, habe den Fehler raus indem ich wie folgt ergänzt habe:
    For Each olAdress In olAdrBook.AddressEntries
Set olContact = olAdress.GetContact
If olContact Is Nothing Then GoTo skipspr
sName = olContact.LastName
sVorname = olContact.FirstName
intOL = intOL + 1
arrNamen_OL(intOL) = sName & ", " & sVorname
skipspr:
Next
Entstanden ist das ganze wohl durch Verteiler die ebenfalls im Adressbuch stehen und die dadurch einen Fehler verursachen.
Leider komme ich jetzt zum nächsten Problem:
Laufzeitfehler 6 Überlauf
und zwar hier:
            For intOL = LBound(arrNamen_OL) To UBound(arrNamen_OL)
LBound ist zu diesem Zeitpunk 1, UBound ist zu diesem Zeitpunkt 76.920
arrNamen_OL wird allerdings aufgelöst mit "Index ausserhalb des gültigen Bereichs"
...?
Anzeige
AW: Prüfung in Outlook Adressbuch (global)
18.07.2016 10:00:44
Jörg
So.
Auch gelöst - Datentyp ist auf long geändert für arrNamen_OL.
Jetzt läuft das Ding zwar durch, bringt mir aber egal ob der Name im Adressbuch steht oder nicht immer alle Namen in den Bereich "Nicht vorhandene Namen".
Ich dreh noch durch :)
AW: Prüfung in Outlook Adressbuch (global)
18.07.2016 14:15:22
Jörg
Hallo zusammen,
ich habe den Code jetzt mal angepasst und zum Laufen bekommen - danke fcs schonmal!!!
Jetzt habe ich allerdings ein Problem. Manche User der Mailingdatei würden gerne eine Emailadresse (Mindestanforderung a@abc.aa) oder einen im Globalen Adressbuch definierten Verteiler verwenden (Benamsung leider völlig wild - also sowohl Kommata als auch Leerzeichen etc :( )
Wie kann ich das abfangen / einbauen?
Anbei der Code von fcs mit meinen Anpassungen - und genau hier weiß ich nicht mehr weiter, wie ich beide Zusatzfunktionen (Internetemail auf Syntax prüfen sowie Verteiler auf Gültigkeit prüfen) umsetzen kann:
Sub Check_Names_Outlook()
Dim olApp As Object  'As Outlook.Application
Dim olAdrBook As Object  'As Outlook.AddressList
Dim olAdress As Object  'As object
Dim olContact As Object  'As Outlook.ContactItem
Dim myNamespace As Object  'As Outlook.Namespace
Dim wksData As Worksheet
Dim bolVorhanden As Boolean
Dim arrNamen, intName As Long, intN_L As Long, intN_U As Long
Dim arrNamen_OL() As String
Dim intOL As Long
Dim sName As String, sVorname As String, sNameVorname As String
Dim arrV(), intV As Integer
Dim arrNV(), intNV As Integer
Set wksData = ActiveWorkbook.Worksheets("Country") 'Tabelle mit den Namen in einer Zelle
Set wksResult = ActiveWorkbook.Worksheets("Preview") 'Tabelle für Zielnamen
'Ergebnis-Arrays vorbereiten
'Outlook-Objekte setzen
Set olApp = VBA.CreateObject("Outlook.Application")
Set myNamespace = olApp.GetNamespace("MAPI")
Set olAdrBook = myNamespace.AddressLists("Globale Adressliste")          'Name ggf.  _
anpassen
'Namen aus Outlook-Adressliste in Datenarray einlesen
ReDim Preserve arrNamen_OL(1 To olAdrBook.AddressEntries.Count)
For Each olAdress In olAdrBook.AddressEntries
Set olContact = olAdress.GetExchangeUser
If olContact Is Nothing Then GoTo skipspr
sName = olContact.LastName
sVorname = olContact.FirstName
intOL = intOL + 1
arrNamen_OL(intOL) = sName & ", " & sVorname
skipspr:
Next
For Each olAdress In olAdrBook.AddressEntries
Set olContact = olAdress.GetExchangeDistributionList
If olContact Is Nothing Then GoTo skipspr2
sName = olContact
intOL = intOL + 1
arrNamen_OL(intOL) = sName
skipspr2:
Next
'Schleife zur Namensprüfung initiieren
iCount = Worksheets("Country").Range("C6").Value
For I = 1 To iCount - 1
sCol = "G"
iRow = 8
sSelect = sCol & (iRow + I)
vselect = "C" & (4 + I)
nvselect = "D" & (4 + I)
sCountry = Worksheets("Country").Range(sSelect).Value
If wksData.Range(sSelect).Value = "" Then GoTo skipspr3
arrNamen = VBA.Split(wksData.Range(sSelect).Text, ";") 'Namen aus Zelle einlesen
intN_L = LBound(arrNamen)
intN_U = UBound(arrNamen)
ReDim Preserve arrV(intN_L To intN_U)
ReDim Preserve arrNV(intN_L To intN_U)
intV = intN_L - 1
intNV = intV
'Namen mit Liste in Outlook abgleichen
For intName = intN_L To intN_U
bolVorhanden = False
If InStr(arrNamen(intName), ",") > 0 Then
sName = Trim(Split(arrNamen(intName), ",")(0))
sVorname = Trim(Split(arrNamen(intName), ",")(1))
sNameVorname = sName & ", " & sVorname
For intOL = LBound(arrNamen_OL) To UBound(arrNamen_OL)
If arrNamen_OL(intOL) = sNameVorname Then
bolVorhanden = True
Exit For
End If
Next
If bolVorhanden = True Then
intV = intV + 1
arrV(intV) = sNameVorname
Else
intNV = intNV + 1
arrNV(intNV) = sNameVorname
End If
End If
Next
'Ergebnis-Daten in Tabellenblatt eintragen
With wksResult
With .Range(vselect) 'vorhandene Namen
If intV >= intN_L Then
ReDim Preserve arrV(intN_L To intV)
.Value = VBA.Join(arrV, ";")
Else
.ClearContents
End If
End With
With .Range(nvselect) 'nicht vorhandene Namen
If intNV >= intN_L Then
ReDim Preserve arrNV(intN_L To intNV)
.Value = VBA.Join(arrNV, ";")
Else
.ClearContents
End If
End With
End With
skipspr3:
Next I
'Objekt-Variablen zurücksetzen
Set olApp = Nothing: Set myNamespace = Nothing: Set olAdrBook = Nothing
Set olContact = Nothing: Set wksData = Nothing
Erase arrV, arrNV, arrNamen, arrNamen_OL
End Sub
Interessanterweise sind alle Verteiler, die ein Komma im Namen haben als gültig anerkannt, nur solche ohne Komma fehlen mir noch.. :(
Anzeige
AW: Prüfung in Outlook Adressbuch (global)
19.07.2016 20:53:30
fcs
Hallo Jörg,
ich mal versucht dein Makro anzupassen, so dass auch "normale" E-Mailadressen und Verteilerlisten erfasst/erkannt werden.
https://www.herber.de/bbs/user/107105.txt
Dazu muss der Typ des Outlook-Adresseintrags geprüft werden und jeweils eine bestimmte Information in ein jetzt 3-Spaltiges Array gespeichert werden (Name, Vorname | E-Mail-Adresse | Verteiler-Name).
Beim Vergleich mit den Namen in den Zellen müssen dann entsprechend mehr Prüfungen durchgeführt werden.
Ich hoffe dass das dann auch mit den Exchange-Server-Adressen funktioniert. Ich konnte nur mit eine lokalen Kontaktdaten-Liste testen.
Gruß
Franz
Anzeige
AW: Prüfung in Outlook Adressbuch (global)
20.07.2016 13:49:23
Jörg
Hallo Franz,
die gute Nachricht vorweg - ja der Code funktioniert bei mir auch für Exchange.
Nur ein Problem habe ich. Wenn ein User als Empfänger eine reguläre Emailadresse angibt (zb. info@hallowelt.de) wird diese als error ausgespuckt. Eben für diese sollte eigentlich aber eine andere Routine laufen, nämlich die Überprüfung ob es eine syntaktisch gültige externe Mailadresse ist(also keine Umlaute, @ Zeichen, Punkt -- ganz rudimentär).
Sorry ich glaube ich hatte mich da in meinem letzten Post etwas ungenau ausgedrückt...
Kann man das noch einbauen?
Vielen Dank auf jeden Fall dass du dich dem Mamut-Code soweit annimmst!!
Gruß
Jörg
Anzeige
AW: Prüfung in Outlook Adressbuch (global)
21.07.2016 22:23:09
fcs
Hallo Jörg,
ich hab für die Überprüfung der Syntax der E-Mail-Adressen eine entsprechende benutzerdefinierte Funktion eingebaut.
https://www.herber.de/bbs/user/107154.txt
Bei den zulässigen Zeichen hab ich mich an den Infos hier
https://de.wikipedia.org/wiki/E-Mail-Adresse
orientiert.
Du kannst die Liste der zulässigen Zeichen in der Function nach deinen Bedürfnissen anpassen.
Gruß
Franz

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige