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

Function ReadGAL(sAlias)
	Dim iJ
	Dim oConn
	Dim oCommand
	Dim oRS
	Dim strQuery
	Dim aGroups
	Dim aMailboxes
	Dim distinguishedName
	Dim ExchangeLegacyDN
	Dim aDN
	Dim bHeaderShown
	Dim sResult
	Dim sHomeMTA
	Dim sADUserObject
	Dim aAuthOrigBL
	Dim 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://" & EXCHANGE_SERVER &_
	                ">;(&(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

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