[Acc2k] Lese-Zugriff auf Active Directory Informationen unter Win2k/Win2k3 Server

[Jörg-M. Müller]

Moin,

ich möchte in eine bestehende Access Datenbank Informationen aus dem AD
importieren und suche Hinweise, Codesnippets, etc.

Danke für die Mithilfe.

Gruß,
Jörg

[Henry Habermacher [MVP Access]]

Hallo Jörg

Kann sein, dass einzelne Zeilen zerschnitten wurden. Ich habe zwar den
Zeilenumbruch auf das maximum eingestellt, aber HTML Postings lässt mein
Provider nicht mehr zu.

quoting Jörg-M. Müller:
> ich möchte in eine bestehende Access Datenbank Informationen aus dem
> AD importieren und suche Hinweise, Codesnippets, etc.

Auf das AD kannst Du per ADODB und LDAP zugreifen.

Anschliessend ein Beispiel, mit dem Du dann weitermachen kannst.

Gruss
Henry

Public Function findMAPIEntry(Optional sAMAccountName As Variant = Null, _
Optional sn As Variant = Null, _
Optional givenname As Variant = Null, _
Optional department As Variant = Null, _
Optional Displayname As Variant = Null, _
Optional LogMode As Variant = False) As
EmployeeDetails

'This function replaces old findMAPIEntry and is now using the LDAP
Directory instead of MAPI
Dim objconn As Object
Dim objCommand As Object
Dim objArgs As Object
Dim objRoot As Object
Dim objDomain As Object
Dim objRS As Object
Dim strDomain As String
Dim strSQL As String
Dim I As Long
Dim J As Long
Dim K As Long
Dim varArray As Variant
Dim varTemp As Variant
Dim varSearch As Variant
Const conMaxEntries As Long = 10

On Error GoTo PROC_ERR

'Create ADO connection object for Active Directory
Set objconn = CreateObject("ADODB.Connection")
objconn.Provider = "ADsDSOObject"
objconn.Open "Active Directory Provider"

'Create ADO command object for the connection.
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objconn

'Get the ADsPath for the domain to search.
Set objRoot = GetObject("LDAP://rootDSE")
strDomain = objRoot.Get("defaultNamingContext")
Set objDomain = GetObject("LDAP://" & strDomain)

'Query
'geht nicht! 3.0.2
'strSQL = "SELECT cn, givenname, initials, sn, displayname, description, "
& _
"physicalDeliveryOfficeName, telephoneNumber, otherTelephone,
mail, " & _
"wWWHomePage, url, streetAddress, postOfficeBox, l, st,
postalCode, " & _
"c, co, countryCode, userPrincipalName, sAMAccountName,
homePhone, " & _
"otherHomePhone, pager, otherPager, mobile, otherMobile,
facsimileTelephoneNumber, " & _
"otherFacsimileTelephoneNumber, ipPhone, otherIpPhone, info,
title, " & _
"department, company, manager" & _
" FROM 'LDAP://" & strDomain & "'" & _
" WHERE objectClass='user' AND objectCategory='person'"
'versuchen wir's mal so
strSQL = "SELECT displayname, cn, sAMAccountName, company, givenname, sn,
l, mail, " & _
"department, telephoneNumber, facsimileTelephoneNumber,
physicalDeliveryOfficeName, Description" & _
" FROM 'LDAP://" & strDomain & "'" & _
" WHERE "

'build searchstring
varSearch = Null
If Len(Nz(sAMAccountName)) > 0 Then
varSearch = "sAMAccountName='" & sAMAccountName & "'"
End If
If Len(Nz(sn)) > 0 Then
varSearch = (varSearch + " AND ") & "sn='" & sn & "*'"
End If
If Len(Nz(givenname)) > 0 Then
varSearch = (varSearch + " AND ") & "givenname='" & givenname & "*'"
End If
If Len(Nz(department)) > 0 Then
varSearch = (varSearch + " AND ") & "department='" & department & "*'"
End If
If Len(Nz(Displayname)) > 0 Then
varSearch = (varSearch + " AND ") & "displayname='" & Displayname & "*'"
End If

'Add searchstring to SQL statement
If Not IsNull(varSearch) Then
strSQL = strSQL & varSearch
End If

'set sort order
'strSQL = strSQL & " ORDER BY displayname"

'Assemble the commandtext
objCommand.CommandText = strSQL

'Execute the query.
Set objRS = objCommand.Execute

Dim arrDescription As Variant
arrDescription = objRS!Description
If VarType(arrDescription) And vbArray = vbArray Then
For I = LBound(arrDescription) To UBound(arrDescription)
Debug.Print "Description)" & I & ") = " & arrDescription(I)
Next
Else
Debug.Print "Description = " & arrDescription
End If

'processing records
findMAPIEntry.bolValid = False
findMAPIEntry.bolUnique = True

If objRS.RecordCount > 0 Then
objRS.MoveFirst
While Not objRS.EOF And findMAPIEntry.bolUnique = True
If findMAPIEntry.bolValid = True Then
If Not LogMode Then
MsgBox "Die Eingabe ist nicht eindeutig. Es wurden mehrere
Einträge im Directory gefunden.", vbInformation
Else
toLog "Nicht eindeutig: " & varSearch
End If
findMAPIEntry.bolUnique = False
End If

If findMAPIEntry.bolUnique = True Then

With objRS
findMAPIEntry.Displayname = Nz(!Displayname)
findMAPIEntry.Alias = Nz(!cn)
findMAPIEntry.PID = Nz(!sAMAccountName)
findMAPIEntry.BU = Nz(!company)
findMAPIEntry.FirstName = Nz(!givenname)
findMAPIEntry.LastName = Nz(!sn)
findMAPIEntry.Location = Replace(Nz(!L), " ", " ")
findMAPIEntry.EMail = Nz(!mail)
findMAPIEntry.Departement = Nz(!department)
findMAPIEntry.Phone = Nz(!telephoneNumber)
findMAPIEntry.BKST = ""
findMAPIEntry.KST = ""
findMAPIEntry.Fax = Nz(!facsimileTelephoneNumber)
findMAPIEntry.Office = Nz(!physicalDeliveryOfficeName)
findMAPIEntry.bolValid = True
End With
End If

objRS.MoveNext
If K >= conMaxEntries Then
MsgBox "Maximale Anzahl von " & conMaxEntries & " Einträgen
überschritten." & _
"Nicht alle Einträge eingelesen. Bitte genauer
spezifizieren.", vbInformation
End If
K = K + 1
Wend
objRS.Close
End If

If findMAPIEntry.bolValid = False Then
If LogMode = False Then
MsgBox "Suche im Directory@Kein Eintrag im Directory
gefunden.@Bedingung: " & varSearch, vbInformation
Else
toLog "Nicht gefunden: " & varSearch
End If
findMAPIEntry.Displayname = ""
findMAPIEntry.Alias = ""
findMAPIEntry.PID = ""
findMAPIEntry.BU = ""
findMAPIEntry.Departement = ""
findMAPIEntry.FirstName = ""
findMAPIEntry.Location = ""
findMAPIEntry.LastName = ""
findMAPIEntry.Phone = ""
findMAPIEntry.EMail = ""
Exit Function
End If

PROC_Exit:
Set objRS = Nothing
Set objconn = Nothing
Exit Function

PROC_ERR:
MsgBox "Fehler beim Lesen des AD Nr. " & Err.Number & vbCrLf & vbCrLf & _
Err.Description & vbCrLf & vbCrLf & _
"Zusatzinformation: " & vbCrLf & _
"Domain = " & strDomain & vbCrLf & _
"Command: " & vbCrLf & strSQL

Resume PROC_Exit

End Function

--
Wichtig: Anmeldetermin für die AEK (siehe FAQ) nicht verpassen!
Keine E-Mails auf Postings in NGs senden!
KB: http://support.microsoft.com/default.aspx
FAQ: http://www.donkarl.com (neu mit Suchfunktion!)
OH: Online Hilfe von Microsoft Access (Taste F1)
Downloads: http://www.dbdev.org

[Henry Habermacher [MVP Access]]

Das mit der maximalen Zeilenlänge hat nicht geklappt. Musst halt die Zeilen
wieder zusammenfügen.

Gruss
Henry

[Henry Habermacher [MVP Access]]

Neuer Versuch, diesmal mit händisch runtergebrochenen Zeilen

quoting Henry Habermacher [MVP Access]:

> Anschliessend ein Beispiel, mit dem Du dann weitermachen kannst.

Hier die neue Version.

Public Function findMAPIEntry( _

Optional sAMAccountName As Variant = Null, _
Optional sn As Variant = Null, _
Optional givenname As Variant = Null, _
Optional department As Variant = Null, _
Optional Displayname As Variant = Null, _
Optional LogMode As Variant = False) As EmployeeDetails

Dim objconn As Object

On Error GoTo PROC_ERR

strSQL = "SELECT displayname, cn, sAMAccountName, " & _

"company, givenname, sn, l, mail, " & _

"department, telephoneNumber, " & _
"facsimileTelephoneNumber, " & _

"physicalDeliveryOfficeName, Description" & _
" FROM 'LDAP://" & strDomain & "'" & _
" WHERE "

'build searchstring
varSearch = Null
If Len(Nz(sAMAccountName)) > 0 Then

varSearch = "sAMAccountName='" & _

sAMAccountName & "'"
End If
If Len(Nz(sn)) > 0 Then

varSearch = (varSearch + " AND ") & _

"sn='" & sn & "*'"
End If
If Len(Nz(givenname)) > 0 Then

varSearch = (varSearch + " AND ") & _

"givenname='" & givenname & "*'"
End If
If Len(Nz(department)) > 0 Then

varSearch = (varSearch + " AND ") & _

"department='" & department & "*'"
End If
If Len(Nz(Displayname)) > 0 Then

varSearch = (varSearch + " AND ") & _

"displayname='" & Displayname & "*'"
End If

'Add searchstring to SQL statement
If Not IsNull(varSearch) Then
strSQL = strSQL & varSearch
End If

'Assemble the commandtext
objCommand.CommandText = strSQL

'Execute the query.
Set objRS = objCommand.Execute

Dim arrDescription As Variant
arrDescription = objRS!Description
If VarType(arrDescription) And vbArray = vbArray Then
For I = LBound(arrDescription) To UBound(arrDescription)

Debug.Print "Description)" & I & ") = " & _

arrDescription(I)
Next
Else
Debug.Print "Description = " & arrDescription
End If

'processing records
findMAPIEntry.bolValid = False
findMAPIEntry.bolUnique = True

If objRS.RecordCount > 0 Then
objRS.MoveFirst
While Not objRS.EOF And findMAPIEntry.bolUnique = True
If findMAPIEntry.bolValid = True Then
If Not LogMode Then

MsgBox "Die Eingabe ist nicht eindeutig. " & _
"Es wurden mehrere Einträge im Directory " & _

MsgBox "Maximale Anzahl von " & conMaxEntries & _
" Einträgen überschritten. Nicht alle Einträge " & _
"eingelesen. Bitte genauer spezifizieren.", _

vbInformation
End If
K = K + 1
Wend
objRS.Close
End If

If findMAPIEntry.bolValid = False Then
If LogMode = False Then

MsgBox "Suche im Directory. " & _
"Kein Eintrag im Directory gefunden. " & _

"Bedingung: " & varSearch, vbInformation
Else
toLog "Nicht gefunden: " & varSearch
End If
findMAPIEntry.Displayname = ""
findMAPIEntry.Alias = ""
findMAPIEntry.PID = ""
findMAPIEntry.BU = ""
findMAPIEntry.Departement = ""
findMAPIEntry.FirstName = ""
findMAPIEntry.Location = ""
findMAPIEntry.LastName = ""
findMAPIEntry.Phone = ""
findMAPIEntry.EMail = ""
Exit Function
End If

PROC_Exit:
Set objRS = Nothing
Set objconn = Nothing
Exit Function

PROC_ERR:
MsgBox "Fehler beim Lesen des AD Nr. " & _