Retrieve Properties of User Objects with ADSI and ADO

Sub Main()

Dim oRootDSE As IADs
Dim oDomain As IADs
Dim obj As IADs
Dim objUser As IADsUser
Dim dacl As IADsAccessControlList
Dim ace As IADsAccessControlEntry
Dim oConnection As New ADODB.Connection
Dim oCommand As New ADODB.Command
Dim RS As ADODB.Recordset
Dim RS2 As ADODB.Recordset
Dim strQuery As String, strAlias As String, mystring As String
Dim varDomainNC As Variant, Desc As Variant, varReports As Variant
Dim PropArray As Variant, Prop As Variant, DescList As Variant
Dim Everyone As Boolean
Dim i As Integer

Const RIGHT_DS_DELETE = &H10000
Const RIGHT_DS_READ = &H20000
Const RIGHT_DS_CHANGE = &H40000
Const RIGHT_DS_TAKE_OWNERSHIP = &H80000
Const RIGHT_DS_MAILBOX_OWNER = &H1
Const RIGHT_DS_SEND_AS = &H2
Const RIGHT_DS_PRIMARY_OWNER = &H4

On Error Resume Next
' To do: change to the alias for the mailbox you are looking for.
strAlias = "EmailAlias"

' Get the Configuration Naming Context.
Set oRootDSE = GetObject("LDAP://RootDSE")
varDomainNC = oRootDSE.Get("defaultNamingContext")
' Open the Connection
oConnection.Provider = "ADsDSOObject"
oConnection.Open "ADs Provider"

' Build the query to find the user based on their alias.
strQuery = "<LDAP://" & varDomainNC & ">;(mailNickName=" & strAlias & ");adspath;subtree"

oCommand.ActiveConnection = oConnection
oCommand.CommandText = strQuery
Set RS = oCommand.Execute
If RS.RecordCount = 0 Then
    Debug.Print strAlias, " is not a valid email alias"
Else
' Iterate through the results.
    While Not RS.EOF
    ' Retrieve the properties and display in debug window.
        Set objUser = GetObject(RS.Fields("adspath"))
        Debug.Print "*************************************************"
        Debug.Print "Information From the Exchange GENERAL Tab:"
        Debug.Print "*************************************************"
        Debug.Print "Mailbox Store:", objUser.homeMDB
        Debug.Print "Alias:", objUser.mailNickname
        Debug.Print "Delivery Restrictions:"
        Debug.Print "    Outgoing Message Size Limit:"
        If objUser.submissionContlength > 0 Then
            Debug.Print "       No Limit: Is Not Selected"
            Debug.Print "       Maxumum Size KB:  Is Selected"
            Debug.Print "       Maximum Size KB: ", objUser.submissionContlength
        Else
            Debug.Print "       No Limit: Is selected"
            Debug.Print "       Maximum Size KB: Is not Selected"
        End If
    
        Debug.Print "    Incoming Message Size:"
        If objUser.delivContLength > 0 Then
            Debug.Print "       No Limit: Is Not Selected"
            Debug.Print "       Maximum Size: Is Selected"
            Debug.Print "       Maximum Size:", objUser.delivContLength
        Else
            Debug.Print "       No Limit: Is Selected"
            Debug.Print "       Maximum Size: Is Not Selected"
        End If
    
        Debug.Print "    Message Restriction:"
        Debug.Print "       Accept Messages from:"
        Everyone = True
' Initialize the array of properties to pass to GetInfoEx.
        PropArray = Array("authOrig", "unauthOrig", "dlMemSubmitPerms", "dlMemRejectPerms")
' Make the array a single variant for passing to GetInfoEx.
        Prop = PropArray
        objUser.GetInfoEx Prop, 0
        Err.Clear
        DescList = objUser.Get("dlMemSubmitPerms")
        If Err.Number <> -2147463155 Then
            Debug.Print "           From Everyone: IS Not Selected"
            Debug.Print "           Only From:"
            For Each Desc In DescList
       ' Print the descriptions.
                Debug.Print "                    ", (Desc)
            Next
            Everyone = False
        End If
        DescList = Null
        Err.Clear
        DescList = objUser.Get("authOrig")
        If Err.Number <> -2147463155 Then
            For Each Desc In DescList
           ' Print the descriptions.
                Debug.Print "                   ", (Desc)
            Next
            Everyone = False
        End If
        DescList = Null
        Err.Clear
        DescList = objUser.Get("dlMemRejectPerms")
        If Err.Number <> -2147463155 Then
            Debug.Print "           From Everyone Except:"
            For Each Desc In DescList
            ' Print the descriptions.
                Debug.Print "                    ", (Desc)
            Next
            Everyone = False
        End If
        DescList = Null
        DescList = objUser.Get("unauthOrig")
        If Err.Number <> -2147463155 Then
            For Each Desc In DescList
           ' Print the descriptions.
                Debug.Print "                   ", (Desc)
            Next
            Everyone = False
        End If
        If Everyone = True Then
            Debug.Print "           From Everyone: Is Selected"
        End If
        Debug.Print "Delivery Options:"
        Debug.Print "    Delegates:"
        Debug.Print "       Grant Permission to:"
        DescList = Null
        Err.Clear
        DescList = objUser.Get("publicDelegates")
        If Err.Number <> -2147463155 Then
            For Each Desc In DescList
           ' Print the descriptions.
                Debug.Print "                   ", (Desc)
            Next
        Else
            Debug.Print "                        Not Set"
        End If
        Debug.Print "       Forwarding Address:", objUser.altRecipient
        If objUser.deliverAndRedirect = True Then
            Debug.Print "        Deliver message to both forwarding address and mailbox: Checked"
        Else
            Debug.Print "        Deliver message to both forwarding address and mailbox: Not Checked"
        End If
        Debug.Print "    Recipient Limits:"
        Err.Clear
        DescList = objUser.Get("msExchRecipLimit")
        If Err.Number <> -2147463155 Then
            For Each Desc In DescList
                Debug.Print "           Maximum users:", objUser.msExchRecipLimit
            Next
        Else
            Debug.Print "                        Not Set"
        End If
    
        Debug.Print "Storage Limits:"
        Debug.Print "    Use mailbox store defaults:", objUser.mdbusedefaults
        Debug.Print "    When mailbox exceeds the indicated amount:"
        Debug.Print "       Issue warning at:", objUser.mdbstoragequota
        Debug.Print "       Prohibit send at:", objUser.mdbOverquotalimit
        Debug.Print "       Prohibit send and receive at:", objUser.mdbOverhardquotalimit
        Debug.Print "       Maximum Size:", objUser.MaxStorage
        Debug.Print "    Deleted items retension:"
        If objUser.deletedItemflags > 0 Then
            Debug.Print "       Use mailbox store defaults:  is Not Checked"
        Else
            Debug.Print "       Use mailbox store defaults:  is Checked"
        End If
        Debug.Print "       Keep deleted items for days:", objUser.garbageCollPeriod / 86400
        If objUser.deletedItemflags = 3 Then
            Debug.Print "       Don't permenently delete until the store has been backed up: is Checked"
        Else
            Debug.Print "       Don't permenently delete until the store has been backed up: is Not Checked"
        End If
        Debug.Print "*************************************************"
        Debug.Print "Information From the Exchange Advanced Tab:"
        Debug.Print "*************************************************"
        Debug.Print "Simple Display Name:", objUser.displayNamePrintable
        Debug.Print "Hide from Exchange Address list", objUser.msExchHidefromAddressLists
        varReports = objUser.securityProtocol
        If varReports(3) <> 0 Then
            Debug.Print "Downgrade high priority mail bound for X400:  Is Checked"
        Else
            Debug.Print "Downgrade high priority mail bound for X400:  Is Not Checked"
        End If
        Debug.Print "Custom Attributes:"
        Debug.Print "                  extensionAttribute1:", objUser.extensionAttribute1
        Debug.Print "                  extensionAttribute2:", objUser.extensionAttribute2
        Debug.Print "                  extensionAttribute3:", objUser.extensionAttribute3
        Debug.Print "                  extensionAttribute4:", objUser.extensionAttribute4
        Debug.Print "                  extensionAttribute5:", objUser.extensionAttribute5
        Debug.Print "                  extensionAttribute6:", objUser.extensionAttribute6
        Debug.Print "                  extensionAttribute7:", objUser.extensionAttribute7
        Debug.Print "                  extensionAttribute8:", objUser.extensionAttribute8
        Debug.Print "                  extensionAttribute9:", objUser.extensionAttribute9
        Debug.Print "                  extensionAttribute10:", objUser.extensionAttribute10
        Debug.Print "                  extensionAttribute11:", objUser.extensionAttribute11
        Debug.Print "                  extensionAttribute12:", objUser.extensionAttribute12
        Debug.Print "                  extensionAttribute13:", objUser.extensionAttribute13
        Debug.Print "                  extensionAttribute14:", objUser.extensionAttribute14
        Debug.Print "                  extensionAttribute15:", objUser.extensionAttribute15
        Debug.Print "Protocol Setting:"
        DescList = Null
        Err.Clear
        DescList = objUser.Get("protocolsettings")
        If Err.Number <> -2147463155 Then
            For Each Desc In DescList
                i = InStr(1, Desc, "�", vbTextCompare)
                If Left(Desc, i - 1) = "HTTP" Then
                    Desc = Right(Desc, Len(Desc) - i)
                    If Left(Desc, 1) = "1" Then
                        Debug.Print "       HTTP: is enabled for mailbox"
                    Else
                        Debug.Print "       HTTP: is not enabled for mailbox"
                    End If
                    Desc = Right(Desc, Len(Desc) - 2)
                    If Left(Desc, 1) = "1" Then
                        Debug.Print "       HTTP: Use protocol defaults"
                    Else
                        Debug.Print "       HTTP: Do not use protocol defaults"
                    End If
                ElseIf Left(Desc, i - 1) = "IMAP4" Then
                    Desc = Right(Desc, Len(Desc) - i)
                    If Left(Desc, 1) = "1" Then
                        Debug.Print "       IMAP4: is enabled for mailbox"
                    Else
                        Debug.Print "       IMAP4: is not enabled for mailbox"
                    End If
                    Desc = Right(Desc, Len(Desc) - 2)
                    If Left(Desc, 1) = "1" Then
                        Debug.Print "       IMAP4: Use server defaults"
                    Else
                        Debug.Print "       IMAP4: Do not use server defaults"
                    End If
                    Debug.Print "       IMAP4 MIME Encoding:"
                    Desc = Right(Desc, Len(Desc) - 2)
                    If Left(Desc, 1) = "0" Then
                        Debug.Print "                      Message should be MIME-encoded with both text and HTML body parts"
                    ElseIf Left(Desc, 1) = "1" Then
                        Debug.Print "                      Message should be MIME-encoded with text only body parts"
                    ElseIf Left(Desc, 1) = "4" Then
                        Debug.Print "                      Message should be MIME-encoded with HTML only body parts"
                    End If
                    Desc = Right(Desc, Len(Desc) - 2)
                    i = InStr(1, Desc, "�", vbTextCompare)
                    Debug.Print "                Default Character set:", Left(Desc, i - 1)
                'The last 4 values are not documented.
                'Setting these programmatically is not supported.

                ElseIf Left(Desc, i - 1) = "POP3" Then
                    Desc = Right(Desc, Len(Desc) - i)
                    If Left(Desc, 1) = "1" Then
                        Debug.Print "       POP3: is enabled for mailbox"
                    Else
                        Debug.Print "       POP3: is not enabled for mailbox"
                    End If
                    Desc = Right(Desc, Len(Desc) - 2)
                    If Left(Desc, 1) = "1" Then
                        Debug.Print "       POP3: Use server defaults"
                    Else
                        Debug.Print "       POP3: Do not use protocol defaults"
                    End If
                    Debug.Print "       POP3 MIME Encoding:"
                    Desc = Right(Desc, Len(Desc) - 2)
                    If Left(Desc, 1) = "0" Then
                        Debug.Print "                      Message should be MIME-encoded with both text and HTML body parts"
                    ElseIf Left(Desc, 1) = "1" Then
                        Debug.Print "                      Message should be MIME-encoded with text only body parts"
                    ElseIf Left(Desc, 1) = "2" Then
                        Debug.Print "       POP3 UUencoding: Is Enabled "
                        Debug.Print "       POP3 UUencoding: Use Binhex for macintosh is enabled"
                    ElseIf Left(Desc, 1) = "3" Then
                        Debug.Print "       POP3 UUencoding: Is Enabled "
                    ElseIf Left(Desc, 1) = "4" Then
                        Debug.Print "                      Message should be MIME-encoded with HTML only body parts"
                    End If
                    Desc = Right(Desc, Len(Desc) - 2)
                    i = InStr(1, Desc, "�", vbTextCompare)
                    Debug.Print "                Default Character set:", Left(Desc, i - 1)
                    i = InStr(1, Desc, "�", vbTextCompare)
                    Desc = Right(Desc, Len(Desc) - i)
                    If Left(Desc, 1) = "0" Then
                        Debug.Print "                     Use Rich Text is not enabled"
                    Else
                        Debug.Print "                     Use Rich Text is enabled"
                    End If
                End If
            Next
        End If
        mystring = "�"
        i = Asc(mystring)
        Debug.Print "ILS Settings"
        i = InStr(1, objUser.autoReplyMessage, "/", vbTextCompare)
        Debug.Print "             ILS Server:", Left(objUser.autoReplyMessage, i - 1)
        Debug.Print "             ILS Account:", Right(objUser.autoReplyMessage, Len(objUser.autoReplyMessage) - i)
    
        DescList = Null
        Err.Clear
        Debug.Print "Mailbox Rights"
        
        ' msExchMailboxSecurityDescriptoris a copy of what is in the MDB.
        ' It cannot be modified programmatically.
        
        objUser.GetInfoEx "msExchMailboxSecurityDescriptor", 0
        Dim objsd As IADsSecurityDescriptor
        Set objsd = objUser.Get("msExchMailboxSecurityDescriptor")
          '----Enumerate an ACE in DACL----
        Set dacl = objsd.DiscretionaryAcl
        For Each ace In dacl

            '----TRUSTEE----

            mystring = ace.Trustee

            '----ACE TYPE-----

            If (ace.AceType = ADS_ACETYPE_ACCESS_ALLOWED) Then
                mystring = "             " & mystring & " is allowed:"
            ElseIf (ace.Type = ADS_ACETYPE_ACCESS_DENIED) Then
                  mystring = "             " & mystring & " is denied:"
            End If

            '----ACE MASK----

            If (ace.AccessMask And RIGHT_DS_SEND_AS) Then
                 mystring = mystring & " -send mail as"
            End If

            If (ace.AccessMask And RIGHT_DS_CHANGE) Then
                mystring = mystring & " -modify user attributes"
            End If

            If (ace.AccessMask And RIGHT_DS_DELETE) Then
                mystring = mystring & " -delete mailbox store"
            End If

            If (ace.AccessMask And RIGHT_DS_READ) Then
                mystring = mystring & " -read permissions"
            End If
            If (ace.AccessMask And RIGHT_DS_TAKE_OWNERSHIP) Then
                mystring = mystring & " -take ownership of this object"
            End If
            If (ace.AccessMask And RIGHT_DS_MAILBOX_OWNER) Then
                mystring = mystring & " -is mailbox owner of this object"
            End If
            If (ace.AccessMask And RIGHT_DS_PRIMARY_OWNER) Then
                mystring = mystring & " -is mailbox Primary owner of this object"
            End If
            
            Debug.Print mystring

        Next
        RS.MoveNext
    Wend
    obj = Nothing
    objUser = Nothing
    dacl = Nothing
    ace = Nothing
    
    End If
    oRootDSE = Nothing
    oDomain = Nothing
    Set oConnection = Nothing
    Set oCommand = Nothing
    Set RS = Nothing
    Set RS2 = Nothing
End Sub