Creating Exchange User from VBA code

[txgeekgirl1]

Hi All - I have a DB for supervisors to use when they hire a new employee. One thing we would like the IS Clerk to do after she has reviewed the info is to be able to click a button and have it create our user with email box.

I have the code tweaked to create the User, assign info/pwd, and add to groups. I am so close to the email part - but coming up with Obj doesn't exist in LDAP. HELP!

I am posting entire code - Create Mailbox is at end. Thanks in advance!!!

Public Function CreateAdAccount(sPassword, sFirstName, sLastName, sGroupName) As Boolean

    CreateAdAccount = True

    Dim oMailbox As CDOEXM.IMailboxStore
    Dim oUser As IADsUser

    Set RootDSE = GetObject("LDAP://RootDSE")
    DomainContainer = RootDSE.Get("defaultNamingContext")
    Set oOU = GetObject("LDAP://CN=Users;DC=pbmhmr,DC=com")

    
    ID = DLookup("StaffID", "NewStaffRequests", "ID = " & myRec)
    gname = Trim(sFirstName)
    sname = Trim(sLastName)
    FullName = gname & " " & sname
    Alias = LCase(Left(gname, 1) & sname)


    ' Test for existing alias name
    'Set conn = CreateObject("ADODB.Connection")
    'conn.Provider = "ADSDSOObject"
    'conn.Open "ADs Provider"
'    ldapStr = ";(&(objectCategory=user)(mailNickname=" & Alias & "));adspath;subtree"
    'ldapStr = ";(&(objectCategory=user)(mail=" & Alias & "));adspath;subtree"
    'Set rs = conn.Execute(ldapStr)
    
    'MsgBox "Matching Names Count = " & Str(rs.RecordCount)
    
    'If rs.RecordCount > 0 Then
        'MsgBox "User email alias already exists!"
    'End If

   
    ' Update User Record
    Set oUser = oOU.Create("user", "cn=" & FullName)
    oUser.Put "cn", FullName
    oUser.Put "SamAccountName", FullName
    oUser.Put "userPrincipalName", FullName & "@pbcc.com"
    oUser.Put "givenName", gname
    oUser.Put "sn", sname
    oUser.Put "mail", Alias & "@pbcc.com"
    oUser.Put "description", ID
    oUser.Put "ScriptPath", "Wlogic.bat"
  
    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


    ' Create Mailbox
   Set oMailbox = oUser
   MDBName = "Mailbox Store (EXCH_CENTER)"
   StorageGroup = "First Storage Group"
   Server = "EXCH_CENTER"
   AdminGroup = "First Administrative Group"
   Organization = "PBCC (Exchange)"
   DomainDN = "DC=pbcc,DC=com"

    oMailbox.CreateMailbox "LDAP://CN=Mailboxes,CN=" & MDBName & _
    ",CN=" & StorageGroup & _
    ",CN=" & Server & _
    ",CN=Servers" & _
    ",CN=" & AdminGroup & _
    ",CN=Administrative Groups" & _
    ",CN=" & Organization & _
    "," & DomainDN
    
    oUser.SetInfo
    
    '",CN=InformationStore" & _
    'CN=Configuration,
    '",CN=Microsoft Exchange,CN=Services" & _

  
    ' Cleanup
    Set oUser = Nothing
 
End Function

 

[txgeekgirl1]

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.

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.")