Beiträge von cheaptrick

Sub KontakteUndGruppenAusOutlookUebernehmen() 
Dim objArbeitsverz  As Outlook.MAPIFolder 
Dim objKon          As Outlook.ContactItem 
Dim objVert         As Outlook.DistListItem 
Dim TempRecipient   As Outlook.Recipient 
Dim AddEntr         As Outlook.AddressEntries 
Dim AddEntrItem     As Outlook.AddressEntries 
Dim rst, rst1, rst2 As Recordset 
Dim dbs             As Database 
Dim i, j, k         As Integer Dim str, str1, str2 As String 
Dim objOutlApp      As New Outlook.Application 
Dim sql             As String 
Dim GRP_ID          As Long 
Dim Kontakt_ID      As Long 
Dim x               As Object 
Dim objRS           As Object      


On Error GoTo Fehler     
Set dbs = CurrentDb     
Set rst1 = dbs.OpenRecordset("Gruppen_Kontakte", dbOpenDynaset)     
Set rst2 = dbs.OpenRecordset("Kontakte", dbOpenDynaset) 
Set rst = dbs.OpenRecordset("Gruppen", dbOpenDynaset)
i = 0     
DoCmd.SetWarnings False     
'vorhandene Kontakte entfernen     
sql = "DELETE FROM Kontakte;"     
DoCmd.RunSQL sql     
'vorhandene Gruppen entfernen     
sql = "DELETE FROM Gruppen;"     
DoCmd.RunSQL sql     
'vorhandene Zuordnungen Gruppe zu Kontakt entfernen     
sql = "DELETE FROM Gruppen_Kontakte;"     
DoCmd.RunSQL sql     
DoCmd.SetWarnings True          
Set AddEntr = objOutlApp.GetNamespace("MAPI").AddressLists("All Users").AddressEntries     
For i = 1 To AddEntr.Count         
'Debug.Print i & ": " & AddEntr.Item(i).Name         
If InStr(AddEntr.Item(i).Name, "CSD_") Then 
rst.AddNew             
rst!Gruppe = AddEntr.Item(i).Name             
GRP_ID = rst!GrpID             
rst.Update             
Set AddEntrItem = AddEntr.Item(i).Members             
For j = 1 To AddEntrItem.Count                 
If AddEntrItem.Item(j).DisplayType = olUser Then                     
str1 = AddEntrItem.Item(j).Name                     
str = "Displayname = '" & str1 & "'"                     rst2.FindFirst str                     
If rst2.NoMatch Then                         rst2.AddNew                         
rst2!displayname = str1                         
Kontakt_ID = rst2!Kontakt_ID                         rst2.Update                     Else                         
Kontakt_ID = rst2!Kontakt_ID                     
End If                     
rst1.AddNew                     
rst1!GRP_ID = GRP_ID                     
rst1!Kontakt_ID = Kontakt_ID                     rst1.Update                 
End If             
Next         
End If     
Next i     
rst.Close     
Set rst = Nothing     
rst1.Close     
Set rst1 = Nothing     
rst2.Close     
Set rst2 = Nothing          
'LDAP-Daten zu den Display-Namen suchen     
Set rst2 = dbs.OpenRecordset("Kontakte", dbOpenDynaset)     rst2.MoveFirst     
While Not rst2.EOF         
Debug.Print rst2!displayname         
Set objRS = searchInAD(, , , , rst2!displayname)         
If IsObject(objRS) Then             
With objRS                 
If .RecordCount > 0 Then                     rst2.Edit                     
rst2!Alias = Nz(!cn)                     
rst2!BU = Nz(!company)                     
rst2!Vorname = Nz(!givenname)                     rst2!Nachname = Nz(!sn)                     
rst2!Location = Nz(!l)                     
rst2!Email = Nz(!mail)                     
rst2!Departement = Nz(!department)                     rst2!Telefon = Nz(!telephoneNumber)                     rst2!Fax = nz(!facsimileTelephoneNumber)                     rst2!mobile = Nz(!mobile)                     
rst2!Office = Nz(!physicalDeliveryOfficeName)                     rst2.Update                 
End If             
End With         
End If         
rst2.MoveNext     
Wend     
MsgBox "Datentransfer erfolgreich beendet!"     
Set objKon = Nothing     
Set objVert = Nothing     
Set objKon = Nothing     
Set objOutlApp = Nothing     
Exit Sub 
Fehler:     
MsgBox Err.Number & ": " & Err.Description     
Resume Next 
End Sub