Connecting to ADSI from VBA in Access (1 Viewer)

txgeekgirl · May 17, 2011

I need to connect to the Active Directory to create new Exchange accounts out of an Access DB. I can get a connection to read through current user settings, but need to be able to add. Any suggestions are greatly appreciated.

DJkarl · May 17, 2011

Here is an example in vbscript, should almost work as-is.

http://www.tek-tips.com/viewthread.cfm?qid=1292635&page=1

txgeekgirl · May 17, 2011

Thank you DJKarl for the Link... That is close to where I was last Thursday. I am still a little stumped with the connection string.

Code:

Set objOU = GetObject("[URL="ldap://ou=companyname,dc=microsoft,dc=dc=com/"]LDAP://ou=companyname,dc=microsoft,dc=dc=com[/URL]")

I think it's because we use a port for AD.

ou=MyCo
dc=Domain
dc=com

so would I just throw the port after the com as com:389

DJkarl · May 17, 2011

As I understand it 389 is the default port for AD, do you need to specify it?

txgeekgirl · May 17, 2011

I have an Object not found on server message. Trying to clear it up. I was hoping that was the reason. I have my Domain for companyname because they are the same. I have looked in some VB code we recently coded but that connection goes ou=companyname,uid=admin,pw=blahblah

DJkarl · May 17, 2011

well if you can log into the AD server it self and run a script

Code:

Set objSysInfo = CreateObject("ADSystemInfo")
objSysInfo.RefreshSchemaCache
WScript.Echo "User name: " & objSysInfo.UserName

it might give you some of the information you're missing.

***Sadly I cannot test this here as I'm not a domain admin or part of the network infrastructure team.

txgeekgirl · May 17, 2011

Oh well... I guess I am off to finding method 2. I will resign to creating and calling vb.net code to write to the AD. I would have loved to have it all contained in VBA but we don't get everything we want. Thanks anyway!

DJkarl · May 17, 2011

Ahh...that stinks...well you could always compile it to a DLL and run that from VBA...it's almost like winning then.

txgeekgirl · May 17, 2011

LOL! I thought I would love working with AD from a code level. I was so exited for this - but my excitement has been nothing but challenges lost.

But Code is Law and I just have to find the right rules to play by.

txgeekgirl · May 17, 2011

OK - new idea sort of.... Telling me I cannot update - Can IO change the statement to let me have admin priviledges.

Dim adoConnection, strBase, strFilter, strAttributes
Dim objRootDSE, strDNSDomain, strQuery, adoRecordset, strName, strCN
' Setup ADO objects.
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
Set adoRecordset = CreateObject("ADODB.Recordset")
Set adoRecordset.ActiveConnection = adoConnection
' Search entire Active Directory domain.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
strBase = "<LDAP://" & strDNSDomain & ">"
' Filter on user objects.
strFilter = "(&(objectCategory=person)(objectClass=user))"
' Comma delimited list of attribute values to retrieve.
strAttributes = "sAMAccountName,cn"
' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
' Run the query.
adoRecordset.Source = strQuery
adoRecordset.Open
With adoRecordset
.AddNew
!cn = "FredFlintstone"
!sAMAccountName = "Fred Flintstone"
!givenname = "Fred"
!sn = "Flintstone"
!displayName = "Fred Flintstone"
!Description = "9999"
!SetPassword = "Password10!"
!PasswordExpired = True
!AccountDisabled = False
.Update
.Bookmark = adoRecordset.LastModified
End With
' Enumerate the resulting recordset.
'Do Until adoRecordset.EOF
' Retrieve values and display.
'strName = adoRecordset.Fields("sAMAccountName").Value
'strCN = adoRecordset.Fields("cn").Value
MsgBox "done"
' Move to the next record in the recordset.
'adoRecordset.MoveNext
'Loop
' Clean up.
adoRecordset.Close
adoConnection.Close

DJkarl · May 18, 2011

So I wouldn't know where to start on altering that statement...but what about running the process as a domain admin, or at least as a user that has permissions to run that.

You could look into impersonation.

I posted an example in this thread on how to logon as a different user to run a process, then log back off.

http://www.access-programmers.co.uk/forums/showthread.php?t=196037

txgeekgirl · Sep 15, 2011

I HAVE IT WORKING and wanted to share the code!

This has been a real pain in the butt endeavor but.... persistance overcomes.

Couple things you should know - where ever you choose to run this code, you must install CDOEXM library/.dll files for use of that library with Access - whether machine or server. The other huge helper for me was installing a free Microsoft add-in called ADExplorer, which gives you a look at how your code has to match up to feed your AD.

This code is getting passed a Record ID named myRec from a form and identifies the table where everything is stored. Since we manage all server security/printer/software permissions and shared folders from AD User Groups, the code for the groups shows that.

Code:

Public Sub CreateAdAccount(myRec)
   
    Dim gname, sname, sGroupName, sPassword, FullName, Alias, MailAlias, MDBName, StorageGroup, Server, AdminGroup, Organization, DomainDN As String
    Dim oMailbox As CDOEXM.IMailboxStore
    Dim oUser As IADsUser
   
    gname = DLookup("NewStaff_F_Name", "NewStaffRequests", "ID = " & myRec)
    sname = DLookup("NewStaff_L_Name", "NewStaffRequests", "ID = " & myRec)
    sGroupName = DLookup("DefaultPrinter", "NewStaffRequests", "ID = " & myRec)
        If Len(DLookup("SharedFolders", "NewStaffRequests", "ID = " & myRec)) > 0 Then
            sGroupName = sGroupName & "," & DLookup("SharedFolders", "NewStaffRequests", "ID = " & myRec)
        End If
        If Len(DLookup("Databases", "NewStaffRequests", "ID = " & myRec)) > 0 Then
            sGroupName = sGroupName & "," & DLookup("Databases", "NewStaffRequests", "ID = " & myRec)
        End If
        If Len(DLookup("EmailGroups", "NewStaffRequests", "ID = " & myRec)) > 0 Then
            sGroupName = sGroupName & "," & DLookup("EmailGroups", "NewStaffRequests", "ID = " & myRec)
        End If
        'clean groups
        sGroupName = Replace(Groups, "NoGroup,", "")
'*****======Time Out =========******
    'Check for existing AD Record
    Dim MySql As String
    
    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
    MySql = "SELECT sAMAccountName FROM 'LDAP://dc=domain,dc=com' WHERE " _
    & "givenName='" & gname & "' AND sn='" & sname & "'"
    
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open MySql, objConnection, 1   ' 1 = adOpenKeyset
    
    If rs.RecordCount = 1 Then
        MsgBox "This User exists on the PBMHMR network. Please call 432-555-5555 for assistance."
        Exit Sub
    End If

    objRecordset.Close
    
'*****====Time Out Ended=====*****
    
        'Open modifying connection to Active Directory
        Set RootDSE = GetObject("LDAP://RootDSE")
        DomainContainer = RootDSE.Get("defaultNamingContext")
        Set oOU = GetObject("LDAP://CN=Users;DC=domain,DC=com")
        
        'Set variables you will need to complete task
            
        ID = DLookup("StaffID", "NewStaffRequests", "ID = " & myRec)
        sPassword = "MyP@ssw0rd"
        FullName = gname & " " & sname
        Alias = LCase(Left(gname, 1) & sname)
        MailAlias = gname & sname
        MDBName = "Mailbox Store (EXCH_CENTER)"
        StorageGroup = "First Storage Group"
        Server = "EXCH_CENTER"
        AdminGroup = "First Administrative Group"
        Organization = "NAMEhere"
        DomainDN = "DC=domain,DC=com"

         ' Update User Record
        Set oUser = oOU.Create("user", "cn=" & FullName)
        oUser.Put "cn", FullName
        oUser.Put "SamAccountName", FullName
        oUser.Put "userPrincipalName", FullName & "@domain.com"
        oUser.Put "givenName", gname
        oUser.Put "sn", sname
        oUser.Put "displayName", FullName
        oUser.Put "mailNickname", MailAlias
        oUser.Put "description", ID
        oUser.Put "ScriptPath", "Slogic.bat"
        oUser.Put "mDBUseDefaults", "TRUE"
        oUser.Put "msExchHomeServerName", "/o=" & Organization & "/ou=" & AdminGroup & "/CN=Configuration/CN=Servers/CN=" & Server
        oUser.Put "showInAddressBook", "CN=Default Global Address List,CN=All Global Address Lists,CN=Address Lists Container," & _
                    "CN=" & Organization & ",CN=Microsoft Exchange,CN=Services,CN=Configuration," & DomainDN
        oUser.Put "proxyAddresses", "smtp:" & Alias & "@domain.com"
        oUser.SetInfo
        oUser.GetInfo
    
    
        ' Enable Account
        oUser.AccountDisabled = False
        ' Set Pwd to be same as 123456
        oUser.SetPassword (sPassword)
        'Account is not disabled
        oUser.AccountDisabled = False
        ' User must change password at next Logon
        oUser.Put "pwdLastSet", CLng(0)
        oUser.SetInfo
        
        ' Add the user to a group
        Dim index As Integer
        Dim sEachGroup As String
        
        Do While Len(sGroupName) > 0
            'End of list - can't have a string going from 1 to 0
            If InStr(sGroupName, ",") <> 0 Then
                index = InStr(sGroupName, ",")
            Else
                index = 50
            End If
            
            sEachGroup = Mid(sGroupName, 1, index - 1)
            'MsgBox (sEachGroup)
            
            StrobjGroup1 = "LDAP://cn=" & sEachGroup & ",cn=Users,DC=pbmhmr,DC=com"
            Set objGroup1 = GetObject(StrobjGroup1)
            objGroup1.Add (oUser.ADsPath)
            
            sGroupName = Mid(sGroupName, index + 1)
        Loop
        
        
        ' Cleanup
        Set oUser = Nothing

        MsgBox ("This employee has been added to Active Directory.")

prley · Oct 11, 2018

thanks much txgeekgirl exactly what i was looking for.

Connecting to ADSI from VBA in Access (1 Viewer)

txgeekgirl

Registered User.

DJkarl

Registered User.

txgeekgirl

Registered User.

DJkarl

Registered User.

txgeekgirl

Registered User.

DJkarl

Registered User.

txgeekgirl

Registered User.

DJkarl

Registered User.

txgeekgirl

Registered User.

txgeekgirl

Registered User.

DJkarl

Registered User.

txgeekgirl

Registered User.

prley

Been Around the Block

Similar threads

Users who are viewing this thread