Results 1 to 2 of 2
  1. #1
    Join Date
    Jan 2002
    Location
    Sweden
    Posts
    11

    Unanswered: Import into Access from Active Directory

    A colleague wants to import user data from Active Directory into Access.

    Does anyone know how this can be done?

  2. #2
    Join Date
    Dec 2004
    Location
    Madison, WI
    Posts
    3,926

    Active Directory getting name

    Here's some code to get the name from the Active Directory.

    You can probably ignore all the rest of the code in this function (it exports and finds matching names in an excel file) but below is the main line in the code (you'll have to tweak it):

    'Set User = GetObject("WinNT://" & UserDomain & "/" & UserName & ",user") - this line marked out as it was experimenting but you may be able to use it.

    On Error Resume Next
    'Main command
    Set User = GetObject("LDAP://jerry/uid=" & UserName & ",ou=People,dc=weccusa,dc=org")

    I hope it works for you. Let me know.

    Here's the full function I used:

    Function hourdump()
    'current path to get xls file
    'Dim SDate, EDate As Date
    'SDate = Forms!Exportformhours!StartDate
    'EDate = Forms!Exportformhours!EndDate
    Dim txtfileName As String
    txtfileName = Forms!ExportFormHours!txtCustFilePath
    sfpath = txtfileName
    'sfpath = Application.CurrentProject.Path
    'sfpath = sfpath & "Terri's Documents\PR Allocation.xls"

    'errorlog excel worksheet
    errlogname = "errorlog"

    'errorlog excel worksheet cell increment
    errlogrow = 1

    'simple way to find if the today is BOM or EOM
    'If Format(Date, "d") < 16 Then
    tabactivate = Forms!ExportFormHours!TabName
    'Else
    ' tabactivate = "EOM-Hours"
    'End If

    'open excel object
    Set objApp = CreateObject("Excel.Application")

    'configure excel object settings
    With objApp

    .Visible = True

    .DisplayAlerts = False

    .Workbooks.Open FileName:=sfpath, UpdateLinks:=0

    'create a errorlog worksheet in the excel file
    'if exist delete and then create it
    On Error Resume Next
    .Sheets(errlogname).Delete
    On Error GoTo 0

    Set errlogsh = objApp.Worksheets.Add(, after:=.Worksheets(.Worksheets.Count))
    errlogsh.Name = errlogname
    Set errlogsh = Nothing

    .Sheets(errlogname).Columns("B:B").Select
    .selection.NumberFormat = "@"

    'choose the appropriate worksheet
    .Sheets(tabactivate).Activate

    End With

    'declare database connection objects
    Dim strSQL As String
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset

    'sql statement
    strSQL = "Select * from ExcelHourDump"

    'get all records and fields from table
    rs.Open strSQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic

    'go to the first record found
    rs.MoveFirst

    'loop through all records found
    Do While Not rs.EOF
    'troubleshooting - show current record values
    'MsgBox rs!LoginID & vbCrLf & rs!ProjCode & vbCrLf & rs!SumOfHours

    'convert login name to full name
    UserName = rs!LoginID

    'get current record sum hours and project code
    CurrentUserSOH = rs!SumOfHours

    Dim CurrentUserProjCode As Variant
    CurrentUserProjCode = rs!ProjCode

    'if there is a -CCCalcs suffix get rid of it
    'UserName = Trim(Replace(UserName, " - CCCalcs", ""))

    'Set User = GetObject("WinNT://" & UserDomain & "/" & UserName & ",user")
    On Error Resume Next
    Set User = GetObject("LDAP://jerry/uid=" & UserName & ",ou=People,dc=weccusa,dc=org")

    'if the user does not exist in the ldap database, add it to the error log
    If err.Number <> 0 Then

    objApp.Sheets(errlogname).Cells(errlogrow, 1).Value = UserName & " could not be found in LDAP"
    objApp.Sheets(errlogname).Cells(errlogrow, 2).Value = CurrentUserProjCode
    objApp.Sheets(errlogname).Cells(errlogrow, 3).Value = CurrentUserSOH
    errlogrow = errlogrow + 1

    GoTo SkipUser:

    End If
    On Error GoTo 0

    UserFullName = User.cn
    UserSN = User.sn

    'regenerate name to be last name comma first name
    CurrentUserFullName = Trim(UserSN) & ", " & Trim(Replace(UserFullName, Trim(UserSN), ""))

    'do the following steps in the excel object
    With objApp

    'turn off error trapping
    On Error Resume Next

    'find and select the user row in the worksheet
    userretval = .Cells.Find(CurrentUserFullName).Select

    'find and get the row number
    UserFullNameRow = .Cells.Find(CurrentUserFullName).Row

    'find and get the project code col number
    ' ProjCodeCol = .Cells.search(CurrentUserProjCode).Column

    'Dim ProjCodeCol As Variant
    ProjCodeCol = .Cells.Find(CurrentUserProjCode, , , 1).Column

    ' ProjCodeCol = .Cells.Find(CurrentUserProjCode).Column
    ' ProjCodeCol = .Cells.Find(CurrentUserProjCode).Column

    ' ProjCodeCol = .Cells.Find(CurrentUserProjCode).Column
    If ProjCodeCol = 1 Then err.Number = 999

    'if there was any problem finding the username or project code
    'log it else if there is no error, change the user's hours
    If err.Number <> 0 Then
    '
    'MsgBox " error" & Err.Number
    .Sheets(errlogname).Cells(errlogrow, 1).Value = CurrentUserFullName
    .Sheets(errlogname).Cells(errlogrow, 2).Value = CurrentUserProjCode
    .Sheets(errlogname).Cells(errlogrow, 3).Value = CurrentUserSOH

    errlogrow = errlogrow + 1

    Else

    'modify the appropriate column for the user
    .Cells(UserFullNameRow, ProjCodeCol).Value = CurrentUserSOH

    End If

    'turn error trapping back on
    On Error GoTo 0

    End With

    'If there is an error come to here
    SkipUser:

    rs.MoveNext
    Loop

    rs.Close
    Set rs = Nothing

    'MsgBox "done"
    'objApp.Quit

    Set objsheet = Nothing
    Set objBook = Nothing
    Set objApp = Nothing


    End Function
    Last edited by pkstormy; 11-23-06 at 19:35.
    Expert Database Programming
    MSAccess since 1.0, SQL Server since 6.5, Visual Basic (5.0, 6.0)

Posting Permissions

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