Results 1 to 3 of 3
  1. #1
    Join Date
    Apr 2015
    Posts
    14

    Unanswered: VBA-Active Directory-MS Access

    My question is how do I fix the following issue:

    All of the fields i have no issue with getting the information other than the "ACCOUNTEXPIRES" field. It is because it does not convert correctly or i have a bad setting. The following URL is something i tried, even modifiying with my limited ability but could not get it to work. http://www.rlmueller.net/Integer8Attributes.htm

    If there is a way to take what is in that link to convert that field to the correct date (ACCOUNTEXPIRES) that is what I am trying to do. The other fields work as intended, please do not let the other code throw you it all works. I hope that better helps to what i am doing. Like i said the other fields work with no issues, it is the one field that is causing me this problem. Thanks again.

    strOU1=LDAP://OU=TEST,DC=Test,DC=TEST,DC=TEST,DC=TEST

    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand = CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Page Size") = 1000
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    objCommand.Properties("Chase referrals") = ADS_CHASE_REFERRALS_EXTERNAL
    objCommand.CommandText = "SELECT givenName, sn, name, department, title, sAMAccountName, accountExpires, userAccountControl FROM '" & strOU1 & "' WHERE objectCategory='user' ORDER BY sAMAccountName"
    Set objRecordset = objCommand.Execute
    While Not objRecordset.EOF
    Set strName = objRecordset.Fields("Name")
    strName = Replace(strName, "'", "''")
    Set strDept = objRecordset.Fields("department")
    Set stradname = objRecordset.Fields("sAMAccountName")
    Set strExp = objRecordset.Fields("accountExpires").Value

    'Set strExp = objRecordset.Fields("accountExpires") 'I have tried this as well in place of the above


    CurrentDb.Execute "Insert Into Test (Tname,adname,dept,exp) Values ( '" & strName & "', '" & stradname & "', '" & strDept & "', '" & strExp & "')", dbFailOnError

    objRecordset.MoveNext
    Wend

    It fails on strEXP, it never gets to the SQL insert.

  2. #2
    Join Date
    Mar 2009
    Posts
    5,442
    Provided Answers: 14
    The is no need to use a Set instruction here. Try:
    Code:
    Dim  varExp As Variant
    varExp = objRecordset.Fields("accountExpires").Value
    Have a nice day!

  3. #3
    Join Date
    Nov 2008
    Posts
    24

    Active Directory Interrogation

    Hi,
    It is often difficult to find information on how to use the Active Directory. Especially examples.
    I use a couple of VBA functions that may help in understanding it (if you use it in your environment).
    This is not directly answering your question but thought it might help you and possibly others.
    '---------------------------------------------------------------------------------------------
    Public Function AD_GetUserEmail(Optional strCN As String) As String
    'Retrieve user's email address from Active Directory

    On Error GoTo ErrHandler

    Dim objADInfo As Object, objADUser As Object
    Dim strArray() As String

    Set objADInfo = CreateObject("ADSystemInfo")

    If strCN > "" Then
    strArray = Split(objADInfo.username, ",")
    strArray(0) = "CN=" & strCN
    Set objADUser = GetObject("LDAP://" & Join(strArray, ","))
    Else
    Set objADUser = GetObject("LDAP://" & objADInfo.username)
    End If

    AD_GetUserEmail = objADUser.Mail


    errExit:
    Set objADUser = Nothing
    Set objADInfo = Nothing
    Exit Function

    ErrHandler:
    Call manage_error(Module_Name, "AD_GetUserEmail", Err.number, Err.Description, True)
    Resume errExit

    End Function
    '---------------------------------------------------------------------------------------------
    Public Function AD_UserInfo(LoginName As String, Optional what As String) As String
    'PURPOSE: Display information that is available in
    'the Active Directory about a given user

    'PARAMETER: Login Name for user

    'RETURNS: String with selected information about
    'user, or empty string if there is no such
    'login on the current domain
    'REQUIRES: Windows 2000 ADSI, LDAP Provider
    'Proper Security Credentials.

    'EXAMPLE: msgbox AD_UserInfo("Administrator","firstname") 'can leave out the firstname for full information

    If Len(LoginName) < 1 Then LoginName = InputBox("Enter user ID")
    Dim conn As New ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim oRoot, oDomain, user
    Dim sBase As String, sFilter As String, sDomain As String
    Dim sAttribs As String, sDepth As String, sQuery As String, sAns As String

    On Error GoTo ErrHandler:

    'Get user Using LDAP/ADO. There is an easier way
    'to bind to a user object using the WinNT provider,
    'but this way is a better for educational purposes
    Set oRoot = GetObject("LDAP://rootDSE")
    'work in the default domain
    sDomain = oRoot.Get("defaultNamingContext")
    Set oDomain = GetObject("LDAP://" & sDomain)
    sBase = "<" & oDomain.ADsPath & ">"
    'Only get user name requested
    sFilter = "(&(objectCategory=person)(objectClass=user)(name= " & LoginName & "))"
    sAttribs = "adsPath"
    sDepth = "subTree"
    sAns = ""
    sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth

    conn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"

    Set rs = conn.Execute(sQuery)

    If Not rs.EOF Then
    Set user = GetObject(rs("adsPath"))
    With user
    'if the attribute is not stored in AD,
    'an error will occur. Therefore, this
    'will return data only from populated attributes
    On Error Resume Next
    If Len(what) < 1 Then
    sAns = "Full Name: " & .FirstName & " " & .LastName & vbCrLf
    sAns = sAns & "Title: " & .Title & vbCrLf
    sAns = sAns & "Division: " & .Department & vbCrLf '& ", " & "Department: " & .Department & vbCrLf
    sAns = sAns & "Phone Number: " & .TelephoneNumber & ", " & "Fax Number: " & .FaxNumber & vbCrLf
    sAns = sAns & "Email Address: " & .EmailAddress & vbCrLf
    sAns = sAns & "Last Login: " & .LastLogin & vbCrLf
    ' sAns = sAns & "Last Logoff: " & .Lastlogoff & vbCrLf
    ' sAns = sAns & "Account Expiration Date: " & .AccountExpirationDate & vbCrLf
    ' sAns = sAns & "Web Page: " & .HomePage & vbCrLf
    ' sAns = sAns & "Employee ID: " & .EmployeeID & vbCrLf & vbCrLf
    'IN RC2, this returned 1/1/1970 when password never expires option is set
    sAns = sAns & "Password Expiration Date: " & .PasswordExpirationDate & vbCrLf & vbCrLf
    sAns = sAns & "************************************************* **********************************" & vbCrLf
    'sAns = sAns & "Manager Details: " & .Manager & vbCrLf
    Dim nname, nnmid
    nname = Split(.Manager, ",")(0)
    nnmid = Mid(nname, 4, Len(nname) - 3)
    sAns = sAns & "Manager: " & AD_UserInfo(Mid(nname, 4, Len(nname) - 3)) & vbCrLf '& nname & vbCrLf & nnmid & vbCrLf
    sAns = sAns & "************************************************* **********************************" & vbCrLf

    Else
    Select Case LCase(what)
    Case "firstname": sAns = .FirstName
    Case "lastname": sAns = .LastName
    Case "fullname": sAns = .FirstName & " " & .LastName
    Case "title": sAns = .Title
    Case "division": sAns = .Division
    Case "department": sAns = .Department
    Case "manager": sAns = .Manager
    Case "telephonenumber": sAns = .TelephoneNumber
    Case "faxnumber": sAns = .FaxNumber
    Case "emailaddress": sAns = .EmailAddress
    Case "homepage": sAns = .HomePage
    Case "lastlogin": sAns = .LastLogin
    Case "lastlogoff": sAns = .Lastlogoff
    Case "passwordexpirationdate": sAns = .PasswordExpirationDate
    End Select
    End If
    End With
    End If
    AD_UserInfo = sAns

    ErrHandler:
    On Error Resume Next
    If Not rs Is Nothing Then
    If rs.State <> 0 Then rs.Close
    Set rs = Nothing
    End If

    If Not conn Is Nothing Then
    If conn.State <> 0 Then conn.Close
    Set conn = Nothing
    End If

    Set oRoot = Nothing
    Set oDomain = Nothing
    End Function
    '---------------------------------------------------------------------------------------------

    Regards
    Tony

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •