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