How to associate an external account with an existing Exchange 2000 mailbox

'********************************************************************
'*
'* Function AddAce(dacl, TrusteeName, gAccessMask, gAceType,
'*            gAceFlags, gFlags, gObjectType, gInheritedObjectType)
'*
'* Purpose: Adds an ACE to a DACL
'* Input:       dacl            Object's Discretionary Access Control List
'*              TrusteeName     SID or Name of the trustee user account
'*              gAccessMask     Access Permissions
'*              gAceType        ACE Types
'*              gAceFlags       Inherit ACEs from the owner of the ACL
'*              gFlags          ACE has an object type or inherited object type
'*              gObjectType     Used for Extended Rights
'*              gInheritedObjectType
'*
'* Output:  Object - New DACL with the ACE added
'*
'********************************************************************

Function AddAce(dacl, TrusteeName, gAccessMask, gAceType, gAceFlags, gFlags, gObjectType, gInheritedObjectType)
' Bubble Error to Calling Function
'On Error Resume Next
    Dim Ace1
    ' Add new ACE.
    Set Ace1 = CreateObject("AccessControlEntry")
    Ace1.AccessMask = gAccessMask
    Ace1.AceType = gAceType
    Ace1.AceFlags = gAceFlags
    Ace1.Flags = gFlags
    Ace1.Trustee = TrusteeName
    'Determine whether ObjectType has to be set
    If CStr(gObjectType) <> "0" Then
       Ace1.ObjectType = gObjectType
    End If

    'Determine whether InheritedObjectType has to be set.
    If CStr(gInheritedObjectType) <> "0" Then
        Ace1.InheritedObjectType = gInheritedObjectType
    End If
    dacl.AddAce Ace1

    ' Kill objects.
    Set Ace1 = Nothing
End Function

'********************************************************************
'*
'* Function ReorderACL(objDACL)
'*
'* Purpose: Reorders a DACL properly
'* Input:       objDACL                     Access Control List (Object)
'*
'* Output:  Object - Reordered DACL
'*
'********************************************************************

Function ReorderACL(objDACL, bMakeExplicit)
    ' Dim objects.
    Dim ImpDenyDacl, ImpDenyObjectDacl, InheritedDacl, ImpAllowDacl, ImpAllowObjectDacl
    Dim objSD, newDACL
    ' Dim other variables.
    Dim ace
    
    ' Set constants.
    Const ADS_ACEFLAG_INHERITED_ACE = &H10
    Const ADS_ACETYPE_ACCESS_ALLOWED = &H0
    Const ADS_ACETYPE_ACCESS_DENIED = &H1
    Const ADS_ACETYPE_ACCESS_ALLOWED_OBJECT = &H5
    Const ADS_ACETYPE_ACCESS_DENIED_OBJECT = &H6
    
    ' Create the new DACL.
    Set objSD = CreateObject("SecurityDescriptor")
    
    ' Create the ACL objects.
    Set newDACL = CreateObject("AccessControlList")
    Set ImpDenyDacl = CreateObject("AccessControlList")
    Set ImpDenyObjectDacl = CreateObject("AccessControlList")
    Set InheritedDacl = CreateObject("AccessControlList")
    Set ImpAllowDacl = CreateObject("AccessControlList")
    Set ImpAllowObjectDacl = CreateObject("AccessControlList")

    ' Loop through the original DACL.
    For Each ace In objDACL
    If bMakeExplicit Then
         If ((ace.AceFlags And ADS_ACEFLAG_INHERITED_ACE) = ADS_ACEFLAG_INHERITED_ACE) Then
            ace.AceFlags = ace.AceFlags Xor ADS_ACEFLAG_INHERITED_ACE
        End If
   Else
     ' The order of inherited ACEs does not matter.  Because you are
     ' adding them to the top of a new list, when they are added back
     ' to the DACL for the object, they will be in the same order as 
     ' originally.  This is a positive side affect of addin items or a LIFO
     ' (Last In First Out) type list'
     InheritedDacl.AddAce ace
   End If
     ' You have an implicit ACE; it belongs in the correct pool.
     Select Case ace.AceType
         Case ADS_ACETYPE_ACCESS_ALLOWED
             ImpAllowDacl.AddAce ace
         Case ADS_ACETYPE_ACCESS_DENIED
             ImpDenyDacl.AddAce ace
         Case ADS_ACETYPE_ACCESS_ALLOWED_OBJECT
             ImpAllowObjectDacl.AddAce ace
         Case ADS_ACETYPE_ACCESS_DENIED_OBJECT
             ImpDenyObjectDacl.AddAce ace
         Case Else
            'Bad Ace, but let's just leave it out for now.
      End Select
   Next
    '
    ' Combine the ACEs in the proper order.
    '   Implicit Deny
    '   Implicit Deny Object
    '   Implicit Allow
    '   Implicit Allow Object
    '   Inherited ACEs
    '
    ' Implicit Deny
    For Each ace In ImpDenyDacl
       newDACL.AddAce ace
    Next
    
    ' Implicit deny object.
    For Each ace In ImpDenyObjectDacl
       newDACL.AddAce ace
    Next
    
    ' Implicit allow.
    For Each ace In ImpAllowDacl
       newDACL.AddAce ace
    Next
    
    ' Implicit allow object.
    For Each ace In ImpAllowObjectDacl
       newDACL.AddAce ace
    Next

    ' Inherited ACEs.
    For Each ace In InheritedDacl
       newDACL.AddAce ace
    Next
    
    'Set the Appropriate revision level for the DACL.
    newDACL.AclRevision = objDACL.AclRevision

    ' Return properly ordered DACL.
    Set ReorderACL = newDACL
    
    ' Kill objects.
    Set newDACL = Nothing
    Set InheritedDacl = Nothing
    Set ImpAllowObjectDacl = Nothing
    Set ImpAllowDacl = Nothing
    Set ImpDenyObjectDacl = Nothing
    Set ImpDenyDacl = Nothing
    Set objSD = Nothing
End Function
Private Sub Command1_Click()
Dim objUser As IADsUser
Dim oSID As New ADsSID
Dim RawSID
Dim oSecurityDescriptor As New SecurityDescriptor
Dim dacl As New AccessControlList
Dim ace As New AccessControlEntry
' You have to change these variables according to your environment.
' This is the external account.
sWinNTPath_Ext_Account = "WinNT://NTDomainName/NTDomainUser"<BR/>
' This is the external account.
sAssocNTAccount = "NTDomainName\NTDomainUser"
' This is the Windows 2000 mailbox-enabled object (Exchange mailbox).
sEx2kMbxPath = "LDAP://Win2KDC/CN=testarticle,cn=users,DC=MyWin2KDomain,DC=com"
' Get directory user object.
Set objUser = GetObject(sEx2kMbxPath)
' User ADsSecurity.dll to determine the user's SID from the NT domain.
oSID.SetAs ADS_SID_WINNT_PATH, sWinNTPath_Ext_Account
RawSID = oSID.GetAs(ADS_SID_RAWSTRING)
' Set msExchMasterAccountSID.
' This is the same task that is performed by ADUnC when checking the "Associated External Account" check box.
' Under the Mailbox Rights in the Exchange Advanced tab on the properties of a user.
objUser.Put "msExchMasterAccountSID", RawSID
objUser.SetInfo

Set oSecurityDescriptor = objUser.MailboxRights
On Error Resume Next
Set oSecurityDescriptor = objUser.Get("msExchMailboxSecurityDescriptor")
If (Err) Then
Debug.Print "The msExchMailboxSecurityDescriptor attribute is empty."
Debug.Print "Hence this user's mailbox does not have any mailbox rights set on it."
Debug.Print "Error (" & Err.Number & "): " & Err.Description
Exit Sub
End If
' Extract the discretionary access control list (ACL) using the IADsSecurityDescriptor interface.
Set dacl = oSecurityDescriptor.DiscretionaryAcl
Debug.Print "Here are the existing ACEs the mailbox's DACL - "
' Enumerate all the access control entries (ACEs) in the ACL using the IADsAccessControlList interface.
' Hence displaying the current mailbox rights.
For Each ace In dacl
' Display all the ACEs' properties using the IADsAccessControlEntry interface.
Debug.Print ace.Trustee & ", " & ace.AccessMask & ", " & ace.AceType & ", " & ace.AceFlags & ", " & ace.Flags & ", " & ace.ObjectType & ", " & ace.InheritedObjectType
Next
' Adding a new ACE for Full Control to allow "Full Control" for the external account over this mailbox.
' This is the same task that is performed by ADUnC when checking the "Full Control" Rights check box.
' Under the Mailbox Rights in the Exchange Advanced tab on the properties of a user.
AddAce dacl, sAssocNTAccount, (ADS_RIGHT_DELETE + ADS_RIGHT_ACTRL_DS_LIST + ADS_RIGHT_DS_CREATE_CHILD + ADS_RIGHT_READ), _
ADS_ACETYPE_ACCESS_ALLOWED, ADS_ACEFLAG_INHERITED_ACE, 0, 0, 0
' Reorder ACEs in the DACL.
Set dacl = ReorderACL(dacl, True)
' Add new DACL to the Security Descriptor.
oSecurityDescriptor.DiscretionaryAcl = dacl
' Save new SD onto the user.
objUser.MailboxRights = Array(oSecurityDescriptor)
objUser.SetInfo
MsgBox "Done"
End Sub