Function ReadGAL(sAlias,sExchangeServerName)
  Dim iJ, oConn, oCommand, oRS, strQuery, aGroups, aMailboxes, distinguishedName, ExchangeLegacyDN, aDN, bHeaderShown
  Dim sResult, sHomeMTA, sADUserObject, aAuthOrigBL, aUnauthOrigBL
  sResult = ""
  set oConn = CreateObject("ADODB.Connection")
  set oCommand = CreateObject("ADODB.Command")
  set oRS = CreateObject("ADODB.Recordset")
  oConn.Provider = "ADsDSOObject"
  oConn.Open "Ads Provider"
  set oCommand.ActiveConnection = oConn
  strQuery= "<LDAP://" & sExchangeServerName & ">;(&(objectClass=person)(uid=" & sAlias & "));uid,cn,mail,adspath,Home-MTA,memberOf,otherMailbox,textEncodedORAddress,distinguishedName;subtree"
  oCommand.CommandText = strQuery
  oCommand.Properties("Page Size") = 99
  set oRS = oCommand.Execute
  if not oRS.EOF then
    While not oRS.EOF
      aGroups = oRS.fields("memberOf")
      aMailboxes = oRS.fields("otherMailbox")
      distinguishedName = oRS.fields("distinguishedName")
      ExchangeLegacyDN = ""
      If distinguishedName <> "" Then
        aDN = Split(distinguishedName,",")
        for iJ = Ubound(aDN) to LBound(aDN) Step -1
          ExchangeLegacyDN = ExchangeLegacyDN & "/" & aDN(iJ)
        next
      End If
      sHomeMTA = Split(oRS.fields("Home-MTA"),",")(1)
      sHomeMTA = Replace(sHomeMTA,"cn=","",1,-1,1)
      sADUserObject = FindUserByMailAddress(oRS.fields("mail"))
      sResult = sResult & "[General]" & vbCRLF
      sResult = sResult & "Alias = " & oRS.fields("uid") & vbCRLF
      sResult = sResult & "Full Name = " & oRS.fields("cn") & vbCRLF
      sResult = sResult & "ADS Path = " & oRS.fields("adspath") & vbCRLF
      sResult = sResult & "Home MTA = " & sHomeMTA & vbCRLF
      sResult = sResult & "Distinguished Name = " & distinguishedName & vbCRLF
      sResult = sResult & "Exchange Legacy DN = " & ExchangeLegacyDN & vbCRLF
      sResult = sResult & "AD User Object = " & sADUserObject & vbCRLF
      sResult = sResult & "" & vbCRLF
      sResult = sResult & "[eMail]" & vbCRLF
      if oRS.fields("mail") <> "" then
        sResult = sResult & "SMTP$" & oRS.fields("mail") & vbCRLF
      end if
      if oRS.fields("textEncodedORAddress") <> "" then
        sResult = sResult & "X400$" & oRS.fields("textEncodedORAddress") & vbCRLF
      end if
      if IsArray(aMailboxes) then
        for iJ = LBound(aMailboxes) to Ubound(aMailboxes)
          sResult = sResult & aMailboxes(iJ) & vbCRLF
        next
      end If
      ' Distribition Lists
      sResult = sResult & "" & vbCRLF
      sResult = sResult & "[Distribition Lists]" & vbCRLF
      if IsArray(aGroups) then
        for iJ = LBound(aGroups) to Ubound(aGroups)
          sResult = sResult & aGroups(iJ) & vbCRLF
        next
      end If
      ' Auth Orig Back Links
      sResult = sResult & "" & vbCRLF
      sResult = sResult & "[Auth-Orig-BL]" & vbCRLF
      aAuthOrigBL = GetAuthOrigBackLinks(sADUserObject)
      if IsArray(aAuthOrigBL) then
        for iJ = LBound(aAuthOrigBL) to Ubound(aAuthOrigBL)
          sResult = sResult & aAuthOrigBL(iJ) & vbCRLF
        next
      end If
      ' Unauth Orig Back Links
      sResult = sResult & "" & vbCRLF
      sResult = sResult & "[Unauth-Orig-BL]" & vbCRLF
      aUnauthOrigBL = GetUnauthOrigBackLinks(sADUserObject)
      if IsArray(aUnauthOrigBL) then
        for iJ = LBound(aUnauthOrigBL) to Ubound(aUnauthOrigBL)
          sResult = sResult & aUnauthOrigBL(iJ) & vbCRLF
        next
      end If
      oRS.MoveNext
    Wend
  End If
  ReadGAL = sResult
end function

' ----------------------------------------------------------------------------

Function GetAuthOrigBackLinks(sUser)
    Dim iI, oUser, aA, oDL, aADCGlobalNames, sScratch
    If sUser = "" Then : Exit Function
    Set oUser = GetObject(sUser)
    aA = oUser.AuthOrigBL
    Set oUser = Nothing
    If IsArray(aA) Then
        For iI = LBound(aA) To UBound(aA)
            Set oDL = GetObject("LDAP://" & aA(iI))
            aADCGlobalNames = oDL.msExchADCGlobalNames
            If IsArray(aADCGlobalNames) Then
                sScratch = aADCGlobalNames(UBound(aADCGlobalNames))
                If InStr(sScratch,":") Then
                    aA(iI) = Split(sScratch,":")(1)
                End if
            End if
            Set oDL = Nothing
        Next
    End if
    GetAuthOrigBackLinks = aA
End Function

' ----------------------------------------------------------------------------

Function GetUnauthOrigBackLinks(sUser)
    Dim iI, oUser, aA, oDL, aADCGlobalNames, sScratch
    If sUser = "" Then : Exit Function
    Set oUser = GetObject(sUser)
    aA = oUser.UnauthOrigBL
    Set oUser = Nothing
    If IsArray(aA) Then
        For iI = LBound(aA) To UBound(aA)
            Set oDL = GetObject("LDAP://" & aA(iI))
            aADCGlobalNames = oDL.msExchADCGlobalNames
            If IsArray(aADCGlobalNames) Then
                sScratch = aADCGlobalNames(UBound(aADCGlobalNames))
                If InStr(sScratch,":") Then
                    aA(iI) = Split(sScratch,":")(1)
                End if
            End if
            Set oDL = Nothing
        Next
    End if
    GetUnauthOrigBackLinks = aA
End Function

' ----------------------------------------------------------------------------

Function FindUserByMailAddress(sEMailAddress)
    Dim oConnection, oCommand, oRoot, sDNSDomain, sQuery, sFilter, oResults
    ' Use ADO to search the domain for all users.
    Set oConnection = CreateObject("ADODB.Connection")
    Set oCommand = CreateObject("ADODB.Command")
    oConnection.Provider = "ADsDSOOBject"
    oConnection.Open "Active Directory Provider"
    Set oCommand.ActiveConnection = oConnection
    ' Determine the DNS domain from the RootDSE object.
    Set oRoot = GetObject("LDAP://RootDSE")
    sDNSDomain = oRoot.Get("DefaultNamingContext")
    sFilter = "(&(ObjectClass=user)(ObjectCategory=person)(mail=" & sEMailAddress & "))"
    sQuery = "<LDAP://" & sDNSDomain & ">;" & sFilter & ";adspath;subtree"
    oCommand.CommandText = sQuery
    oCommand.Properties("Page Size") = 100
    oCommand.Properties("Timeout") = 30
    oCommand.Properties("Cache Results") = False
    Set oResults = oCommand.Execute
    Do Until oResults.EOF
        FindUserByMailAddress = oResults.Fields("adsPath")
        oResults.MoveNext
    Loop
End Function

' ----------------------------------------------------------------------------