Office: (Office 2010) öffentlichen Kontakte Ordner abfragen

wb_3001 · 22. März 2015

Hallo Matthias!

Ich hänge an einem Exchange Server
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Dann kann mein Code nicht funktionieren.
Selbst wenn ich einen fände, ich könnte ihn auch nicht testen.
Ob in diesem Forum sonst jemand helfen kann?
Vielleicht hilft doch Google weiter.

Wolfgang

CptChaos · 23. März 2015

Ich beziehe mich auf den Post #8.
Woran hakt es hier genau? Der folgende Code funktioniert bei mir (ich befinde mich ebenfalls in einer Exchange-Umgebung) fehlerfrei. Code:

Public Sub GetOLAddressList()
On Error GoTo Exit_GetOLAddressList

'EarlyBinding:
'Dim olApp As Outlook.Application
'Dim olAddressList As Outlook.addressList

'Set olApp = New Outlook.Application

'LateBinding:
Dim olApp As Object
Dim olAddressList As Object

Set olApp = CreateObject("Outlook.Application")
Set olAddressList = olApp.GetNamespace("MAPI").AddressLists("Global Address List")

Debug.Print olAddressList.AddressEntries.Count

Exit_GetOLAddressList:
Dim errMsg As String
Select Case Err.Number
Case 0
Case Else
errMsg = "Error occurred in OutlookLib.GetOLAddressList" & vbNewLine & "ErrorNumber: " & Err.Number & vbNewLine & "Description: " & Err.Description & vbNewLine & "Source: " & Err.Source
MsgBox errMsg, vbCritical, "Error in OutlookLib"
Err.Raise Err.Number, Err.Source & vbNewLine & vbTab & "OutlookLib.GetOLAddressList", Err.Description
End Select
GoSub CleanUp
Exit Sub

CleanUp:
Set olAddressList = Nothing
Set olApp = Nothing
Return

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Der Name/Bezeichner der Addressliste ist korrekt?

magic1708 · 24. März 2015

Hallo,

hat etwas gedauert.. Aber ich habe die LÖsung !

Der Code bewirkt nun, dass Alle Öffentlichen Kontakte in einem Unterordner in eine Tabelle geschrieben werden. Dabei wird noch eine Prüfung durchgeführt Hier auf Vor- und Nachname.

Code:

Sub KontakteausOutlook(Mainz_Lieferanten As Boolean)

Dim appout As Object
Dim objArbeitsverz As Object
Dim objKon As Object
Dim rst As Recordset
Dim dbs As Database
Dim intz As Integer
Dim intneu As Integer
Dim intupd As Integer
Dim strNachname As String
Dim strvorname As String

'Objektvariablen auf die Öffentlichen Ordner, samt Verweise auf diese.

Dim objNS As NameSpace
Dim objPF As MAPIFolder
Dim objAPF As MAPIFolder
Dim objMKF As MAPIFolder
Dim objUKF As MAPIFolder
Dim objPKF As MAPIFolder

Set objNS = GetNamespace("MAPI")

Set objPF = objNS.Folders("Öffentliche Ordner - " & objNS.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress) '
Set objAPF = objPF.Folders("Alle Öffentlichen Ordner")
Set objMKF = objAPF.Folders("NL MZ")

If Mainz_Lieferanten = True Then
Set objUKF = objMKF.Folders("Kontakte NL MZ")
Set objPKF = objUKF.Folders("Lieferanten")
Else
Set objUKF = objMKF.Folders("Kompetenzzentrum_Mainz")
Set objPKF = objUKF
End If

intz = 0
intneu = 0
intupd = 0

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Kontakte", dbOpenDynaset)

Set appout = CreateObject("Outlook.Application")

Set objArbeitsverz = objPKF

For intz = 1 To objArbeitsverz.Items.Count
Set objKon = objArbeitsverz.Items(intz)
strNachname = objKon.LastName
strvorname = objKon.FirstName
strNachname = "nachname = '" & strNachname & "'"

With objKon
rst.FindFirst strNachname
If rst.NoMatch Then
rst.AddNew
rst!Firma = .CompanyName
rst!nachname = .LastName
rst!Vorname = .FirstName
rst!Telefon = .BusinessTelephoneNumber
rst!mail = .Email1Address
intneu = intneu + 1
Else
If rst!Vorname = strvorname Then
rst.Edit
rst!Firma = .CompanyName
rst!Telefon = .BusinessTelephoneNumber
rst!mail = .Email1Address
intupd = intupd + 1
Else
rst.AddNew
rst!Firma = .CompanyName
rst!nachname = .LastName
rst!Vorname = .FirstName
rst!Telefon = .BusinessTelephoneNumber
rst!mail = .Email1Address
intneu = intneu + 1
End If
End If
End With

rst.Update
Next intz
MsgBox "Datentransfer erfolgreich beendet! " & vbLf & _
"Es wurden " & intneu & " Sätze angelegt, " & vbLf & _
"Es wurden " & intupd & " Sätze aktualisiert!"
rst.Close

Exit Sub

Fehler:
MsgBox Err.Number & " " & Err.Description
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Office: (Office 2010) öffentlichen Kontakte Ordner abfragen

öffentlichen Kontakte Ordner abfragen

öffentlichen Kontakte Ordner abfragen

öffentlichen Kontakte Ordner abfragen - Similar Threads - öffentlichen Kontakte Ordner

Öffentlicher Ordner Kontakte aktualisieren

Öffentliche Ordner - Gelesen/Ungelesen Einstellung

Teams Liveereignis als öffentlich konfigurieren

Öffentliche Besprechung in Microsoft Teams

Kanal in einem Team von privat auf öffentlich stellen

Öffentliche Kontakte

Bestimmte Kontake aus öffentlichen Kontakten synchronisieren