Create Access database utilizing dtat from Active Directory

[vanlanjl]

I have currently been assigned to create a database (told to do it in
Access), that would keep track of emplyee/user information and employee/user
Asset information. By Assets I mean computer name, computer asset#, serial
number and some other stuff. In the process of creating this form, it became
apparant that all the user data is stored in active directory already. So I
would like to be able to access Active Directory from Access into a user
table instead of putting all the information manually. Is this possable? And
how would i do this. I am not a programmer but have taken some classes, any
help would be great. Thanks!

 

[Tony Toews [MVP]]

I have currently been assigned to create a database (told to do it in
Access), that would keep track of emplyee/user information and employee/user
Asset information. By Assets I mean computer name, computer asset#, serial
number and some other stuff. In the process of creating this form, it became
apparant that all the user data is stored in active directory already. So I
would like to be able to access Active Directory from Access into a user
table instead of putting all the information manually. Is this possable? And
how would i do this. I am not a programmer but have taken some classes, any
help would be great.

The problem is that the code required to access Active Directory is
not that simple and requires intermediate to expert programmer
knowledge.

The following are various links that I found when I was doing a
similar project. They may or may not help you.

http://groups.google.ca/groups?hl=e...=off&q=adsi+search+organizationalunit&spell=1

http://msdn.microsoft.com/library/d...ry/en-us/dnanchor/html/anch_activediradsi.asp

Active Directory Service Interfaces Quick-start Tutorials
Pasted from
<http://msdn.microsoft.com/library/en-us/adsi/adsi/adsi_quick-start_tutorials.asp?frame=true>


IADsAccessControlEntry
Pasted from
<http://msdn.microsoft.com/library/en-us/adsi/adsi/iadsaccesscontrolentry.asp?frame=true>

Also Richard is a fellow MVP and has lots of sample code at his
website. It's VBScript but should still work reasonably well.

http://www.rlmueller.net/products.htm

Tony
--
Tony Toews, Microsoft Access MVP
Please respond only in the newsgroups so that others can
read the entire thread of messages.
Microsoft Access Links, Hints, Tips & Accounting Systems at
http://www.granite.ab.ca/accsmstr.htm
Tony's Microsoft Access Blog - http://msmvps.com/blogs/access/

 

[vanlanjl]

I have been given a vb code from a devolper at my company who actually got it
from the links you had posted. He has modified it and for all intents and
purposes it does work. I ran it in cmd prompt and it created a very sloppy
txtx file that did have all the information that i need.

So i do i take this code and apply it to access where when i open the
database it has an automatic connection to active directory and is updated?

' CreateUserList83.vbs finished August 10, 2007
' VBScript program to create a text file listing all user accounts in the.
' AD domain. Original Script from www.rlmueller website below.
' This VB Script will auto discover your Active Directory Domain.
' I added several user attributes to extract.
' Example of the command line is:
' csscript CreateUserList83.vbs output.txt.
' output.txt is a Tab seperated value text file good for importing into excel.
' Typically this script can be run by any authenticated user in the domain
' because any information returned is information standard users can search on
' with other tools.
' This script also contains the ability to get users home email server, and
message store and storage group
' as well as distinguished, Samaccount name, Full name, Office Designation,
City, Real SMTP address,
' Employee ID, if user account is disabled.
' Added the ability to read the attribute lastLogonTimestamp by reading it
from only one domain controller.
' This atribute only works on AD in 2003 Native mode and is only replicaed
once every 2 weeks.
' August 10, th recient add is the homeDirectory attribute.
' ----------------------------------------------------------------------
' Copyright (c) 2002 Richard L. Mueller
' Hilltop Lab web site - http://www.rlmueller.net
' Version 1.0 - November 10, 2002
' Version 1.1 - February 4, 2003
' Version 1.2 - February 19, 2003 - Standardize Hungarian notation.
' Version 1.3 - January 25, 2004 - Modify error trapping.
' This program enumerates all users in the domain and writes each user's
' LDAP DistinguishedName to a text file, one name per line.
'
' You have a royalty-free right to use, modify, reproduce, and
' distribute this script file in any way you find useful, provided that
' you agree that the copyright owner above has no warranty, obligations,
' or liability for such use.
'  Modified list to create a TAB Seperated value (TSV)
' File for a more complete listing of user information
' And ignore Commas in Relizon's DN format.

Option Explicit

Dim strFilePath, objFSO, objFile, objConnection, objCommand, objRootDSE
Dim strDNSDomain, strFilter, strQuery, objRecordSet, strDN,
strprimaryTelexNumber, strEmail
Dim strUPN, strDisName, strFName, strMI, strLName, strSAM, strName,
strOffice, strempid
Dim strMailNickname, colstrProxyAddresses, strproxyAddresses,
colstrDescription, strDescription
Dim strPrimarySmtp, strNumber, intSmtpPosa, intSmtpPosb, intSmtpPosc,
intSmtpPosd, strSecondarySmtp, strTertiarySmtp, StrSmpttest
Dim strhomeMDB, strCity, strscriptPath, strlegacyExchangeDN, strhomeDirectory
Dim intuserAccountControl, struserAccountDisabled, strAccountLocked,
struserAccountNormal, struserPasswordDontExpire
Dim lngTZBias, objUser, objPwdLastSet, objlastLogonTimestamp
Dim objShell, lngBiasKey, k

'Lets define the constants needed for enumerating the userAccountControl
attribute
Const ADS_UF_ACCOUNTDISABLE = &h2					'User Account iS Disabled
Const ADS_UF_LOCKOUT = &h10							'User Account is Locked
'Const ADS_UF_PASSWD_NOTREQD = &h00020
'Const ADS_UF_PASSWD_CANT_CHANGE = &h00040
'Const ADS_UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED = &h00080
Const ADS_UF_NORMAL_ACCOUNT = &h00200				'Is account normal
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000			'User Password will never expire
'const ADS_UF_PASSWORD_EXPIRED = &h80000			'user Password is expired

' Check for required arguments.
If Wscript.Arguments.Count < 1 Then
Wscript.Echo "Arguments <FileName> required. For example:" & vbCrLf _
& "cscript CreateUserList5.vbs c:\MyFolder\UserList5.txt"
Wscript.Quit(0)
End If

' Obtain local Time Zone bias from machine registry.
Set objShell = CreateObject("Wscript.Shell")
lngBiasKey = objShell.RegRead("HKLM\System\CurrentControlSet\Control\" _
& "TimeZoneInformation\ActiveTimeBias")
If UCase(TypeName(lngBiasKey)) = "LONG" Then
lngTZBias = lngBiasKey
ElseIf UCase(TypeName(lngBiasKey)) = "VARIANT()" Then
lngTZBias = 0
For k = 0 To UBound(lngBiasKey)
lngTZBias = lngTZBias + (lngBiasKey(k) * 256^k)
Next
End If

strFilePath = Wscript.Arguments(0)
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Open the file for write access.
On Error Resume Next
Set objFile = objFSO.OpenTextFile(strFilePath, 2, True, 0)
If Err.Number <> 0 Then
On Error GoTo 0
Wscript.Echo "File " & strFilePath & " cannot be opened"
Wscript.Quit(1)
End If
On Error GoTo 0

' Use ADO to search the domain for all users.
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOOBject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

' Determine the DNS domain from the RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
strFilter = "(&(objectCategory=person)(objectClass=user))"
strQuery = "<LDAP://" & strDNSDomain & ">;" & strFilter _
&
";distinguishedName,sAMAccountName,primaryTelexNumber,mail,mailNickname,proxyAddresses,userPrincipalName,displayName,givenName,initials,sn,name,physicalDeliveryOfficeName,L,scriptpath,homeMDB,employeeID,description,userAccountControl,legacyExchangeDN,homeDirectory;subtree"
objCommand.CommandText = strQuery
objCommand.Properties("Page Size") = 100
objCommand.Properties("Timeout") = 30
objCommand.Properties("Cache Results") = False
objFile.WriteLine "Distinguished Name" & vbtab & "SAMAccountName" & vbtab
& "D.A.M. Application Value" & vbtab & "Not SMTP Email Address" & vbtab &
"Email-alias" & vbtab & "Primary Reply-to SMTP Address" & vbtab & "Secondary
SMTP Address" & vbtab & "Tertiary SMTP Address" & vbtab & "UPN" _
& vbtab & "Display Name" & vbtab & "First Name" & vbtab & "Initial" &
vbtab & "Last Name" & vbtab & "Name"  & vbtab & "Office" & vbtab & "City" &
vbtab & "Logon Script" & vbtab & "Home Directory" & vbtab & "Home Exchange
Server and Database" & vbtab & "Employee ID" & vbtab & "Description" _
& vbtab & "Password Last Changed" & vbtab & "Last Logon Time Stamp"  &
vbtab & "Is Account Disabled?" & vbtab & "user Account Locked out" & vbtab &
"User Password Will Never Expire" & vbtab & "Normal user Account" & vbtab &
"userAccountControl Value" & vbtab & "Exchange Legacy DN"
' Enumerate all users. Write each user's Distinguished Name to the file.
Set objRecordSet = objCommand.Execute
Do Until objRecordSet.EOF
strDN = objRecordSet.Fields("distinguishedName")
strSAM = objRecordSet.Fields("sAMAccountName")
strprimaryTelexNumber = objRecordSet.Fields("primaryTelexNumber")
strEmail = objRecordSet.Fields("mail")
strMailNickname = objRecordSet.Fields("mailNickname")
strUPN = objRecordSet.Fields("userPrincipalName")
strDisName = objRecordSet.Fields("displayname")
strFName = objRecordSet.Fields("givenName")
strMI = objRecordSet.Fields("initials")
strLName = objRecordSet.Fields("sn")
strName = objRecordSet.Fields("name")
strOffice = objRecordSet.Fields("physicalDeliveryOfficeName")
strCity = objRecordSet.Fields("l")
strscriptPath = objRecordSet.Fields("scriptPath")
strhomeDirectory = objRecordSet.Fields("homeDirectory")
strhomeMDB = objRecordSet.Fields("homeMDB")
strempid = objRecordSet.Fields("employeeID")
strlegacyExchangeDN = objRecordSet.Fields("legacyExchangeDN")
colstrproxyAddresses = objRecordSet.Fields("proxyAddresses")
' Set up to enumerate Multi-Valued String attribute "proxyAddresses" for
Primary SMTP
' Initialize varables to Null or 0
strproxyAddresses = ""
intSmtpPosa = 0
intSmtpPosb = 0
strPrimarySmtp = ""
' For those user accounts with no SMTP address continue on error
' Add a + at the end of each row for easy identification for end of row'
On Error Resume Next
For Each strNumber In colstrproxyAddresses
strproxyAddresses = strproxyAddresses & "+" & vbCrLf & strNumber
Next
'This line needed to be added to add a "+" at the end of the last line
strproxyAddresses = strproxyAddresses & "+" & vbCrLf & (strNumber +1)
'End the enumeration of the attribute proxyAddresses
' Find the Main "SMTP:" Address in the list of many smtp addresses and get
its position in the string
intSmtpPosa = (Instr(1, strproxyAddresses, "SMTP:", 0))
intSmtpPosb = Instr(intSmtpPosa, strproxyAddresses, "+", 0)
'Now that we have the starting position and the ending position of the
' reply-to SMTP address grab it from the multi-valued string
' If the account has no SMTP address, then say so in list
strPrimarySmtp = MID(strproxyAddresses, (intSmtpPosa +5) , (intSmtpPosb -
(intSmtpPosa +5)))
if strPrimarySmtp = "" Then
strPrimarySmtp = "This user Account Has No Primary SMPT Address"
end if
'End finding the users Primary SMTP: Address
' Set up to enumerate Multi-Valued String attribute "proxyAddresses" for
Secondary SMTP
' Initialize varables to Null or 0
strproxyAddresses = ""
intSmtpPosa = 0
intSmtpPosb = 0
strSecondarySmtp = ""
' For those user accounts with no SMTP address continue on error
' Add a + at the end of each row for easy identification for end of row'
On Error Resume Next
For Each strNumber In colstrproxyAddresses
strproxyAddresses = strproxyAddresses & "+" & vbCrLf & strNumber
Next
'This line needed to be added to add a "+" at the end of the last line
strproxyAddresses = strproxyAddresses & "+" & vbCrLf & (strNumber +1)
'End the enumeration of the attribute proxyAddresses
' Find the First(Secondary) "smtp:" Address in the list of many smtp
addresses and get its position in the string
intSmtpPosa = (Instr(1, strproxyAddresses, "smtp:", 0))
intSmtpPosb = Instr(intSmtpPosa, strproxyAddresses, "+", 0)
'Now that we have the starting position and the ending position of the
'Secondary SMTP address grab it from the multi-valued string
'If there is no secondary SMTP address say so
if MID(strproxyAddresses, intSmtpPosa , 5) = "smtp:"  Then
strSecondarySmtp = MID(strproxyAddresses, (intSmtpPosa +5) , (intSmtpPosb
- (intSmtpPosa +5)))
end if
if strSecondarySmtp = "" Then
strSecondarySmtp = "This user Account Has No Secondary SMPT Address"
end if
'End finding the users Secondary SMTP: Address

' Set up to enumerate Multi-Valued String attribute "proxyAddresses" for
Tertiary SMTP
' Initialize varables to Null or 0
strproxyAddresses = ""
intSmtpPosa = 0
intSmtpPosb = 0
intSmtpPosc = 0
intSmtpPosd = 0
strTertiarySmtp = ""
' For those user accounts with no SMTP address continue on error
' Add a + at the end of each row for easy identification for end of row'
On Error Resume Next
For Each strNumber In colstrproxyAddresses
strproxyAddresses = strproxyAddresses & "+" & vbCrLf & strNumber
Next
'This line needed to be added to add a "+" at the end of the last line
strproxyAddresses = strproxyAddresses & "+" & vbCrLf & (strNumber +1)
'End the enumeration of the attribute proxyAddresses
' Find the Tertiary "smtp:" Address in the list of many smtp addresses and
get its position in the string
intSmtpPosa = (Instr(1, strproxyAddresses, "smtp:", 0)+5)
intSmtpPosb = Instr(intSmtpPosa, strproxyAddresses, "+", 0)
intSmtpPosc = (Instr(intSmtpPosb, strproxyAddresses, "smtp:", 0))
intSmtpPosd = Instr(intSmtpPosc, strproxyAddresses, "+", 0)
'Now that we have the starting position and the ending position of the
' Tertiary SMTP address grab it from the multi-valued string
'If there is no secondary SMTP address say so
if MID(strproxyAddresses, intSmtpPosc , 5) = "smtp:"  Then
strTertiarySmtp = MID(strproxyAddresses, (intSmtpPosc +5) , (intSmtpPosd -
(intSmtpPosc +5)))
end if
if strTertiarySmtp = "" Then
strTertiarySmtp = "This user Account Has No Tertiary SMPT Address"
end if
'End finding the users Tertiary SMTP: Address

colstrDescription = objRecordSet.Fields("description")
' Set up to enumerate Multi-Valued Sring attribute "description"
' Initialize varables to Null or 0
strDescription = ""
For Each strNumber In colstrDescription
strDescription = strDescription & strNumber
Next
' End the enumberation of description
' read the userAccountControl attribute. Then determine what bits are set.
intuserAccountControl = objRecordSet.Fields("userAccountControl")

'Determine users password was last changed.
Set objUser = GetObject("LDAP://" & strDN)
Set objPwdLastSet = objUser.pwdLastSet

'Determine user lastLogonTimestamp. Good for only AD 2003 Nativemode.
Set objUser = GetObject("LDAP://" & strDN)
Set objlastLogonTimestamp = objUser.lastLogonTimestamp

'Determine of the Account is Disabled userAccountControl=0xh02
If intuserAccountControl And ADS_UF_ACCOUNTDISABLE Then
struserAccountDisabled = "TRUE"
Else
struserAccountDisabled = "FALSE"
End If
intuserAccountLocked
'
'Determine if the Account is "Normal" Account userAccountControl=0xh00200
If intuserAccountControl And ADS_UF_NORMAL_ACCOUNT Then
struserAccountNormal = "TRUE"
Else
struserAccountNormal = "FALSE"
End If

'Determine if the password is set to Never expire userAccountControl=0xh10000
If intuserAccountControl And ADS_UF_DONT_EXPIRE_PASSWD Then
struserPasswordDontExpire = "TRUE"
Else
struserPasswordDontExpire = "FALSE"
End If
'Determin if the user account is locked out userAccountControl=0xh10
If intuserAccountControl And ADS_UF_LOCKOUT Then
strAccountLocked = "TRUE"
Else
strAccountLocked = "FALSE"
End if
'End of account userAccountControl determination

objFile.WriteLine strDN & vbtab & strSAM & vbtab & strprimaryTelexNumber &
vbtab & strEmail & vbtab & strMailNickname & vbtab & strPrimarySmtp & vbtab &
strSecondarySmtp & vbtab & strTertiarySmtp & vbtab & strUPN _

& vbtab & strDisName & vbtab & strFName & vbtab & strMI & vbtab & strLName
& vbtab & strName & vbtab & strOffice & vbtab & strCity & vbtab &
strscriptpath & vbtab & strhomeDirectory & vbtab & strhomeMDB & vbtab &
strempid & vbtab & strDescription _
& vbtab & Integer8Date(objPwdLastSet, lngTZBias) & vbtab &
Integer8Date(objlastLogonTimestamp, lngTZBias) & vbtab &
struserAccountDisabled & vbtab & strAccountLocked  & vbtab &
struserPasswordDontExpire & vbtab & struserAccountNormal & vbtab &
intuserAccountControl & vbtab & strlegacyExchangeDN
objRecordSet.MoveNext



Loop




' Clean up and end script
objFile.Close
objConnection.Close
Set objFile = Nothing
Set objFSO = Nothing
Set objConnection = Nothing
Set objCommand = Nothing
Set objRootDSE = Nothing
Set objRecordSet = Nothing

Wscript.Echo "Done"

Function Integer8Date(objDate, lngBias)
' Function to convert Integer8 (64-bit) value to a date, adjusted for
' local time zone bias.
Dim lngAdjust, lngDate, lngHigh, lngLow
lngAdjust = lngBias
lngHigh = objDate.HighPart
lngLow = objdate.LowPart
' Account for error in IADslargeInteger property methods.
If lngLow < 0 Then
lngHigh = lngHigh + 1
End If
If (lngHigh = 0) And (lngLow = 0) Then
lngAdjust = 0
End If
lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) _
+ lngLow) / 600000000 - lngAdjust) / 1440
' Trap error if lngDate is ridiculously huge.
On Error Resume Next
Integer8Date = CDate(lngDate)
If Err.Number <> 0 Then
On Error GoTo 0
Integer8Date = #1/1/1601#
End If
On Error GoTo 0
End Function

[code/]