Globales Adressbuch durchsuchen

Function GetMail(strName As String) As String Dim outApp As Outlook.Application Dim outNms As Outlook.Namespace Dim outAddr As Outlook.AddressList Dim outRcpt As Outlook.AddressEntry On Error GoTo MailError Set outApp = New Outlook.Application Set outNms = outApp.GetNamespace("MAPI") Set outAddr = outNms.AddressLists("Globale Adressliste") Set outRcpt = outAddr.AddressEntries(strName) GetMail = outRcpt.GetExchangeUser.PrimarySmtpAddress Exit Function MailError: Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext Exit Function End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Zusammen,
ich habe das Problem gelöst :D
Falls jemand ein ähnliches Problem hat, hier die Lösung:
Habe das ganze in zwei Funktionen aufgeteilt,
die Erste sucht den Namen im GAL und gibt den passenden exakten Namen des Eintrags aus.
Beim mehreren Treffern wird eine Userform geöffnet,
welche über eine ComboBox abfragt welchen man gerne hätte.
Mehr als 10 Einträge lasse ich dabei aber nicht zu.
Die Rückgabe dieser Funktion ist also ein eindeutiger Name im GAL!
Die zweite Funktion ist eine simple Rückgabe der e-Mail Adresse
für die Eingabe des nun eindeutigen Namens.
Die Userform mit der ComboBox darf dabei aber nicht vollständig deaktiviert werden,
da die ComboBox in der Funktion ausgelesen werden muss.
Sie hat bei mir zwei Buttons "OK" (Me.hide) und "abbrechen" (Unload Me & End)
Hier der Code:

Function SearchGAL(strName As String) As String
Dim objSession, objGAL, objRcpts As Object
Dim intRcpt As Integer
On Error GoTo GALError
Set objSession = CreateObject("Redemption.RDOSession")
objSession.Logon
Set objGAL = objSession.AddressBook.GAL
Set objRcpts = objGAL.ResolveNameEx(strName)
SearchGAL = objRcpts(1).Name
If objRcpts.Count = 0 Then
MsgBox ("Kontakt '" & strName & "' konnte nicht gefunden werden")
End
End If
If objRcpts.Count > 10 Then 'Nicht mehr als 10 Treffer anbieten
MsgBox ("Angabe zu ungenau")
End
End If
If objRcpts.Count > 1 Then
With frmRcpts   'Userform mit Cbo (cboRcpts) und 2 Cmds
.Enabled = True
For intRcpt = 1 To objRcpts.Count
.cboRcpts.AddItem objRcpts(intRcpt) 'Treffer in Cbo einfügen
Next
.cboRcpts.Value = frmRcpts.cboRcpts.List(0)
.Show
SearchGAL = .cboRcpts.Value 'Namensauswahl aus cbo
.Enabled = False
End With
End If
Exit Function
GALError:
MsgBox "An error occures in modul: " & Application.VBE.ActiveCodePane.CodeModule.Name &  _
vbCrLf & _
"Error number: " & Err.Number & vbCrLf & "Describtion: " & Err.Description
On Error Resume Next
Set objSession = Nothing
Set objGAL = Nothing
Set objRcpts = Nothing
End
End Function

Function GetMail(strRcpt As String) As String
Dim outApp As Outlook.Application
Dim outNms As Outlook.Namespace
Dim outAddr As Outlook.AddressList
Dim outRcpt As Outlook.AddressEntry
On Error GoTo MailError
Set outApp = New Outlook.Application
Set outNms = outApp.GetNamespace("MAPI")
Set outAddr = outNms.AddressLists("Globale Adressliste")
Set outRcpt = outAddr.AddressEntries(strRcpt)
GetMail = outRcpt.GetExchangeUser.PrimarySmtpAddress
Exit Function
MailError:
MsgBox "An error occures in modul: " & Application.VBE.ActiveCodePane.CodeModule.Name &  _
vbCrLf & _
"Error number: " & Err.Number & vbCrLf & "Describtion: " & Err.Description
On Error Resume Next
Set outApp = Nothing
Set outNms = Nothing
Set outAddr = Nothing
Set outRcpt = Nothing
End
End Function

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

3 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Globales Adressbuch durchsuchen

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

3 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread