Connecting to ADSI from VBA in Access (1 Viewer)

txgeekgirl

Registered User.
Local time
Today, 07:16
Joined
Jul 31, 2008
Messages
187
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. :D
 

txgeekgirl

Registered User.
Local time
Today, 07:16
Joined
Jul 31, 2008
Messages
187
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

Registered User.
Local time
Today, 09:16
Joined
Mar 16, 2007
Messages
1,028
As I understand it 389 is the default port for AD, do you need to specify it?
 

txgeekgirl

Registered User.
Local time
Today, 07:16
Joined
Jul 31, 2008
Messages
187
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

Registered User.
Local time
Today, 09:16
Joined
Mar 16, 2007
Messages
1,028
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

Registered User.
Local time
Today, 07:16
Joined
Jul 31, 2008
Messages
187
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

Registered User.
Local time
Today, 09:16
Joined
Mar 16, 2007
Messages
1,028
Ahh...that stinks...well you could always compile it to a DLL and run that from VBA...it's almost like winning then. ;)
 

txgeekgirl

Registered User.
Local time
Today, 07:16
Joined
Jul 31, 2008
Messages
187
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

Registered User.
Local time
Today, 07:16
Joined
Jul 31, 2008
Messages
187
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

Registered User.
Local time
Today, 09:16
Joined
Mar 16, 2007
Messages
1,028
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

Registered User.
Local time
Today, 07:16
Joined
Jul 31, 2008
Messages
187
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

Been Around the Block
Local time
Today, 10:16
Joined
Oct 26, 2007
Messages
37
thanks much txgeekgirl exactly what i was looking for.
 

Users who are viewing this thread

Top Bottom