Listing Trusts

A script to enumerate trust information from an Active Directory forest.

Const ADS_SCOPE_SUBTREE = 2

' Trust Type
' http://msdn.microsoft.com/en-us/library/cc223771(PROT.10).aspx
Dim objTrustTypes
Set objTrustTypes = CreateObject("Scripting.Dictionary")
objTrustTypes.Add 4, "DCE"
objTrustTypes.Add 3, "MIT"
objTrustTypes.Add 2, "UpLevel"
objTrustTypes.Add 1, "DownLevel"

' Trust Attributes
' http://msdn.microsoft.com/en-us/library/cc223779(PROT.10).aspx
Dim objTrustAttributes
Set objTrustAttributes = CreateObject("Scripting.Dictionary") 
objTrustAttributes.Add 128, "UsesRC4Encryption"
objTrustAttributes.Add 64, "TreatAsExternal"
objTrustAttributes.Add 32, "WithinForest"
objTrustAttributes.Add 16, "CrossOrganisation"
objTrustAttributes.Add 8, "ForestTransitive"
objTrustAttributes.Add 4, "QuarantinedDomain"
objTrustAttributes.Add 2, "UpLevelOnly"
objTrustAttributes.Add 1, "NonTransitive"

' Trust Direction
' http://msdn.microsoft.com/en-us/library/cc223768(PROT.10).aspx
Dim objTrustDirection
Set objTrustDirection = CreateObject("Scripting.Dictionary") 
objTrustDirection.Add 3, "BiDirectional"
objTrustDirection.Add 2, "Outbound"
objTrustDirection.Add 1, "Inbound"
objTrustDirection.Add 0, "Disabled"

Dim objConnection : Set objConnection = CreateObject("ADODB.Connection") 
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"

Dim objCommand : Set objCommand = CreateObject("ADODB.Command") 
objCommand.ActiveConnection = objConnection

Dim objRootDSE : Set objRootDSE = GetObject("LDAP://RootDSE") 
objCommand.CommandText = "SELECT distinguishedName, name, trustType, " & _
    "trustAttributes, trustDirection, trustPartner, whenCreated " & _
    "FROM 'GC://" & objRootDSE.Get("rootDomainNamingContext") & _
    "' WHERE objectClass='trustedDomain'"
    
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Timeout") = 600
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 
objCommand.Properties("Cache Results") = False

Dim objRecordSet : Set objRecordSet = objCommand.Execute
While Not objRecordSet.EOF
    WScript.Echo "Trusted Domain: " & objRecordSet.Fields("name").Value 
    WScript.Echo "Trust Type: " & objTrustTypes(objRecordSet.Fields("trustType").Value)
    
    Dim dblFlag Dim strFlags : strFlags = ""
    For Each dblFlag in objTrustAttributes
        If objRecordSet.Fields("trustAttributes").Value And dblFlag Then
            strFlags = strFlags & objTrustAttributes(dblFlag) & " "
        End If
    Next
    WScript.Echo "Trust Attributes: " & strFlags
    WScript.Echo "Trust Direction: " & _
        objTrustDirection(objRecordSet.Fields("trustDirection").Value) 
    WScript.Echo "Trust Partner: " & objRecordSet.Fields("trustPartner").Value
    WScript.Echo "Distinguished Name: " & _
        objRecordSet.Fields("distinguishedName").Value
    WScript.Echo "Created: " & objRecordSet.Fields("whenCreated").Value
    
    objRecordSet.MoveNext
Wend
objConnection.Close

Usage example

In the past I have used the script above to monitor trust settings across a forest. The following script uses the trust information to build a text file storing trust configuration sends an e-mail if that configuration changes.

Option Explicit
 
' Script to get trusts, compare with stored configuration and notify if changed
Sub ShowUsage
    Dim strUsage
    
    strUsage = "Usage:" & vbCrLf & vbCrLf & _
        WScript.ScriptName & _
        " /Command:[Update | Notify] [/MailServer:<servername>] [/Recipient:<address>]" & vbCrLf & vbCrLf & _
        "Arguments:" & vbCrLf & vbCrLf & _
        " Command Update - Updates the contents of the text file with data from the global catalog" & vbCrLf & _
        " Notify - Notifies the recipient using mailserver if the trust data changes" & vbCrLf & _
        " MailServer Server used to send mail. Default: localhost" & vbCrLf & _
        " Recipient Email address of person or group to notify" & vbCrLf
    
    WScript.Echo strUsage
    WScript.Quit
End Sub

Function GetTrusts
    ' Returns a Scripting.Dictionary object containing details of the Trust
    ' Format:
    ' Key: DistinguishedName
    ' Data: Array(
    '    Trusted Domain,
    '    Type,
    '    Attributes,
    '    Direction,
    '    Partner,
    '    Created,
    '    Changed
    ' )
    
    Const ADS_SCOPE_SUBTREE = 2
    
    ' Trust Type
    ' http://msdn.microsoft.com/en-us/library/cc223771(PROT.10).aspx
    Dim objTrustTypes
    Set objTrustTypes = CreateObject("Scripting.Dictionary")
    objTrustTypes.Add 4, "DCE"
    objTrustTypes.Add 3, "MIT"
    objTrustTypes.Add 2, "UpLevel"
    objTrustTypes.Add 1, "DownLevel"

    ' Trust Attributes
    ' http://msdn.microsoft.com/en-us/library/cc223779(PROT.10).aspx
    Dim objTrustAttributes
    Set objTrustAttributes = CreateObject("Scripting.Dictionary") 
    objTrustAttributes.Add 128, "UsesRC4Encryption"
    objTrustAttributes.Add 64, "TreatAsExternal"
    objTrustAttributes.Add 32, "WithinForest"
    objTrustAttributes.Add 16, "CrossOrganisation"
    objTrustAttributes.Add 8, "ForestTransitive"
    objTrustAttributes.Add 4, "QuarantinedDomain"
    objTrustAttributes.Add 2, "UpLevelOnly"
    objTrustAttributes.Add 1, "NonTransitive"

    ' Trust Direction
    ' http://msdn.microsoft.com/en-us/library/cc223768(PROT.10).aspx
    Dim objTrustDirection
    Set objTrustDirection = CreateObject("Scripting.Dictionary") 
    objTrustDirection.Add 3, "BiDirectional"
    objTrustDirection.Add 2, "Outbound"
    objTrustDirection.Add 1, "Inbound"
    objTrustDirection.Add 0, "Disabled"

    Dim objConnection : Set objConnection = CreateObject("ADODB.Connection")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    
    Dim objCommand : Set objCommand = CreateObject("ADODB.Command")
    objCommand.ActiveConnection = objConnection
    
    Dim objRootDSE : Set objRootDSE = GetObject("LDAP://RootDSE")
    objCommand.CommandText = "SELECT distinguishedName, name, " & _
        "trustType, trustAttributes, trustDirection, trustPartner, whenCreated, whenChanged " & _
        "FROM 'GC://" & objRootDSE.Get("rootDomainNamingContext") & "' WHERE objectClass='trustedDomain'"
        
    objCommand.Properties("Page Size") = 1000
    objCommand.Properties("Timeout") = 600
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    objCommand.Properties("Cache Results") = False
    
    Dim objRecordSet : Set objRecordSet = objCommand.Execute
    
    Dim objTrusts : Set objTrusts = CreateObject("Scripting.Dictionary")
    While Not objRecordSet.EOF
        Dim dblFlag Dim strAttributes : strAttributes = ""
        For Each dblFlag in objTrustAttributes
            If objRecordSet.Fields("trustAttributes").Value And dblFlag Then
                strAttributes = strAttributes & objTrustAttributes(dblFlag) & " "
            End If
        Next
        objTrusts.Add objRecordSet.Fields("distinguishedName").Value, Array( _
            objRecordSet.Fields("name").Value, _
            objTrustTypes(objRecordSet.Fields("trustType").Value), _
            strAttributes, _
            objTrustDirection(objRecordSet.Fields("trustDirection").Value), _
            objRecordSet.Fields("trustPartner").Value, _
            objRecordSet.Fields("whenCreated").Value, _
            objRecordSet.Fields("whenChanged").Value)
            
        objRecordSet.MoveNext
    Wend
    
    objConnection.Close 
    
    Set objRecordSet = Nothing
    Set objCommand = Nothing
    Set objConnection = Nothing
    
    Set GetTrusts = objTrusts
End Function

Sub SendMail(strRecipient, strBody, strMailServer)
    Set objMail = CreateObject("CDO.Message")
    objMail.Subject = "Trust monitor"
    objMail.From = strRecipient
    objMail.To = strRecipient
    objMail.TextBody = strBody
    
    objMail.Configuration.Fields.Item _ 
        ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    objMail.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strMailServer
    objMail.Configuration.Fields.Item _ 
        ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    objMail.Configuration.Fields.Update
    
    objMail.Send
End Sub

'
' Main Code
'

Dim objFileSystem
Set objFileSystem = CreateObject("Scripting.FileSystemObject")

Dim objFile
Dim objTrusts : Set objTrusts = GetTrusts

If LCase(WScript.Arguments.Named("command")) = "update" Then
    Set objFile = objFileSystem.OpenTextFile("Trusts.txt", 2, True, 0)

    Dim strDN 
    For Each strDN in objTrusts
        objFile.WriteLine strDN & vbTab & Join(objTrusts(strDN), vbTab)
    Next
ElseIf LCase(WScript.Arguments.Named("command")) = "notify" Then
    strRecipient = WScript.Arguments.Named("recipient")
    If strRecipient = "" Then
        WScript.Echo "ERROR: No recipient defined"
        
        ShowUsage
    End If
    
    strMailServer = WScript.Arguments.Named("mailserver")
    If strMailServer = "" Then
        strMailServer = "localhost"
    End If
    
    If objFileSystem.FileExists("Trusts.txt") Then
        Set objFile = objFileSystem.OpenTextFile("Trusts.txt", 1, False, 0) 
        
        Dim objTrustsInFile
        Set objTrustsInFile = CreateObject("Scripting.Dictionary")
        
        Dim arrTrustData()
        Do While Not objFile.AtEndOfStream
            Dim arrTrustInFile : arrTrustInFile = Split(objFile.ReadLine, vbTab)
            ReDim arrTrustData(0)
            
            Dim i
            For i = 1 to UBound(arrTrustInFile)
                ReDim Preserve arrTrustData(i - 1)
                arrTrustData(i - 1) = arrTrustInFile(i)
            Next
            objTrustsInFile.Add arrTrustInFile(0), arrTrustData
        Loop
    End If
    
    Dim strTrust
    
    ' Comparison - Check for new Trusts
    Dim objNewTrusts : Set objNewTrusts = CreateObject("Scripting.Dictionary")
    For Each strTrust in objTrusts
        If Not objTrustsInFile.Exists(strTrust) Then
            objNewTrusts.Add strTrust, objTrusts(strTrust)
        End If
    Next
    
    ' Comparison - Check for removed Trusts
    Dim objRemovedTrusts
    Set objRemovedTrusts = CreateObject("Scripting.Dictionary")
    For Each strTrust in objTrustsInFile
        If Not objTrusts.Exists(strTrust) Then
            objRemovedTrusts.Add strTrust, objTrustsInFile(strTrust)
        End If
    Next
    
    ' Data: Array(
    '    Trusted Domain,
    '    Type,
    '    Attributes,
    '    Direction,
    '    Partner,
    '    Created,
    '    Changed )
    
    Dim strMessageBody
    Dim booNotify : booNotify = False
    
    If objNewTrusts.Count > 0 Then
        booNotify = True
        
        strMessageBody = "New Trusts:" & vbCrLf & vbCrLf
        
        For Each strTrust in objNewTrusts
            strMessageBody = strMessageBody & "DN: " & strTrust & vbCrLf & _
                "Trusted Domain: " & objNewTrusts(strTrust)(0) & vbCrLf & _
                "Type: " & objNewTrusts(strTrust)(1) & vbCrLf & _
                "Attributes: " & objNewTrusts(strTrust)(2) & vbCrLf & _
                "Direction: " & objNewTrusts(strTrust)(3) & vbCrLf & _
                "Partner: " & objNewTrusts(strTrust)(4) & vbCrLf & _
                "Created: " & objNewTrusts(strTrust)(5) & vbCrLf & _
                "Changed: " & objNewTrusts(strTrust)(6) & vbCrLf & vbCrLf
                
        Next
    End If
    
    If objRemovedTrusts.Count > 0 Then
        booNotify = True
        
        For Each strTrust in objRemovedTrusts
            strMessageBody = strMessageBody & "DN: " & strTrust & vbCrLf & _
            "Trusted Domain: " & objRemovedTrusts(strTrust)(0) & vbCrLf & _
            "Type: " & objRemovedTrusts(strTrust)(1) & vbCrLf & _
            "Attributes: " & objRemovedTrusts(strTrust)(2) & vbCrLf & _
            "Direction: " & objRemovedTrusts(strTrust)(3) & vbCrLf & _
            "Partner: " & objRemovedTrusts(strTrust)(4) & vbCrLf & _
            "Created: " & objRemovedTrusts(strTrust)(5) & vbCrLf & _
            "Changed: " & objRemovedTrusts(strTrust)(6) & vbCrLf & vbCrLf
            
        Next
    End If

    If booNotify = True Then
        strMessageBody = strMessageBody & _
            "If these trusts are correct please run " & _
            WScript.ScriptName & " /Command:Update"
                
        SendMail strRecipient, strMessageBody, strMailServer
    End If
Else
    ShowUsage
End If