Enumerating Exchange Object Properties with ADSI/ADO

Article
08/20/2015
Enumerating Exchange Object Properties with ADSI/ADO

This content is no longer actively maintained. It is provided as is, for anyone who may still be using these technologies, with no warranties or claims of accuracy with regard to the most recent product version or service release.
Visual Basic

'
' Enumerating Exchange Object Properties with ADSI/ADO
' This sample will help you identify the LDAP properties that are 
' displayed by the Users and Computers snap-in when you view the
' User objects Exchange General and Exchange Advanced tabs.
' This sample requires a reference to the following libraries:
' Visual Basic Project References
'  - Microsoft ActiveX Data Objects 2.5 Library (msado15.dll)
'  - Active DS Type Library (activeds.tlb)

     

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
' TODO: Change to the alias of the mailbox you are looking for.
strAlias = "User1"

' 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 the 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 e-mail alias"
Else

' Iterate through the results.
While Not RS.EOF

' Retrieve the properties and display them in the 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 " Maximum 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 retention:"
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 permanently delete until the store has been backed up: is Checked"
Else
Debug.Print " Don't permanently 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 four 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"

' msExchMailboxSecurityDescriptor is 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
Set obj = Nothing
Set objUser = Nothing
Set dacl = Nothing
Set ace = Nothing

End If
Set oRootDSE = Nothing
Set oDomain = Nothing
Set oConnection = Nothing
Set oCommand = Nothing
Set RS = Nothing
Set RS2 = Nothing
End Sub
Send us your feedback about the Microsoft Exchange Server 2003 SDK.
Build: June 2007 (2007.618.1)
Enumerating Exchange Object Properties with ADSI/ADO

Enumerating Exchange Object Properties with ADSI/ADO

Visual Basic

Additional resources
