Option Explicit
'-------------------------------------------------------------------------
' RGADMap.vbs
'
' Beschreibung
' Mit Exchange 2007 werden die AD Sites und Sitelinks zum Routing genutzt
' Aber auch heute ist es ein "gutes Design" wenn beide Einstellungen passen
'
' Das Script macht folgende
' - Liest alle AD Sites mit ihren Subnetzen aus
' - liest alle Exchange Server und deren IP-Adressen
'
' Generiert eine Liste:  Exchangserver, AD Site, Routinggroup
'
' Später auch "Matchen" der Connectoren möglich
'
' Das Skript wird mit den Berechtigungen des angemeldeten Benutzers
' ausgeführt. Die entsprechenden Berechtigungen sind sicher zu stellen
'
' ACHTUNG: Grenzen
' - Umgebungen mit mehr als 100 Servern in einer RG werden aktuell nicht
'   unterstützt wg getex(msExchRoutingGroupMembersBL)
' - Alle Server müssen "PING"bar sein, um die IP-Adresse zu erhalten
'
' (c)2006 Net at Work Netzwerksysteme GmbH
'
' Windows XP oder Windows 2003 erforderlich wg WMIPING mit Win32_PingStatus
'
' Version 1.0 (22. Dec 2005) Frank Carius
'   Erstes release
' Version 1.1 (22. Jun 2006) Frank Carius
'   Trennung nach NOSITE  und NOPING
' Version 1.2 (23. Jun 2006) Frank Carius
'	XSLT Stylesheet kennzeichnet NOPING und NOSIRE farblich
'
'-------------------------------------------------------------------------

Dim total
Dim strQuery, strOutFilePrefix
dim objDebug, xmlwriter, count
dim strsource, strtarget
dim strServerName
dim strServerIP
dim clsADSite, clsADCache, clsExchange, clsWMIPing
dim ExchangeServerDN, rgDN, rgmemberDN

strOutFilePrefix = makefilename("RGADMap-" & Date() & "-" & Time())  ' common name of the output files without extension
set objdebug = new DebugWriter 
objDebug.target = "file:6 console:5" ' errorlogging  0=only output, 1=Error 2=Warning 3=information  5++ =debug
objDebug.outFile = strOutFilePrefix &".log"
objDebug.start

call ForceCScript  ' must be rund with CSCRIPT
objDebug.writeln "RGADMap: gestartet", 0

set xmlWriter = new XmlTextWriter
xmlWriter.filename = strOutFilePrefix & ".xml"
xmlWriter.Indentation = 4
call xmlWriter.WriteStylesheet("RGADMap.xsl")
call writexslt("RGADMap.xsl")
call xmlWriter.WriteStartElement("RGADMap")
call xmlWriter.WriteElementString("starttime1", now())

set clsADSite = new ADSites
set clsADCache = new ADCache
set clsExchange = new MSXFAQExchange
set clsWMIPing = new WMIPing

'
'  Walk though all Exchange Servers
'
total = ubound(clsExchange.getAllServerListDN)+1
call xmlWriter.WriteElementString("total1", total)
call xmlWriter.WriteElementString("starttime2", now())

for each ExchangeServerDN in clsExchange.getAllServerListDN
	objDebug.writeln "Object:" & total & ":" & left(ExchangeServerDN,30)&".." ,4
	total = total - 1
	
    call xmlWriter.WriteStartElement("server")
    call xmlWriter.WriteElementString("dn",ExchangeServerDN)

    strServerName = clsExchange.getServerName(ExchangeServerDN)
    call xmlWriter.WriteElementString("name",strServerName)

    strServerIP = clsWMIPing.Ping(strServerName)
    call xmlWriter.WriteElementString("ip",strServerIP)
    if strServerIP = "0.0.0.0" then
        call xmlWriter.WriteElementString("adsite","NOPING")
    else
        call xmlWriter.WriteElementString("adsite",clsADSite.getsiteforip(strServerIP))
    end if
    call xmlWriter.WriteElementString("rgdn",clsExchange.getRGMembership(ExchangeServerDN))
    call xmlWriter.WriteElementString("rg",clsADCache.GetProperty(clsExchange.getRGMembership(ExchangeServerDN),"name"))
    call xmlWriter.WriteEndElement()   ' of ("RGADMap"
next
objDebug.writeln "Total Records skipped:" & total, 0
call xmlWriter.WriteElementString("total2", total)

call xmlWriter.WriteElementString("endtime", now())
call xmlWriter.WriteEndElement()   ' of ("RGADMap")
objdebug.writeln "Write XML-Output",0
call xmlWriter.Close               ' XML schreiben
objdebug.writeln "RGADMap finished",0
WScript.quit(0)


sub writexslt(strfilename)
	dim txtxsl
	txtxsl = _
		"<?xml version=""1.0"" encoding=""utf-8"" ?> " & vbcrlf & _
		"<xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"">" & vbcrlf & _
		"<xsl:template match=""/"">" & vbcrlf & _
		"<html>" & vbcrlf & _
		"<head><title>RGADMap Status</title></head>" & vbcrlf & _
		"<body>" & vbcrlf & _
		"<h1>RGADMap Status</h1> " & vbcrlf & _
		"<h2>Summary</h2> " & vbcrlf & _
		"<xsl:for-each select=""RGADMap""> " & vbcrlf & _
		"<table border=""1"" width=""100%"">" & vbcrlf & _
		"	<tr><th>Starttime</th><td><xsl:value-of select=""starttime1"" /></td></tr>" & vbcrlf & _
		"	<tr><th>Endtime</th> <td><xsl:value-of select=""endtime"" /></td></tr>" & vbcrlf & _
		"	<tr><th># Sitelinks total</th><td bgcolor=""#FFFFFF""><xsl:value-of select=""total1""/></td></tr>" & vbcrlf & _
		"	<tr><th># Sitelinks skipped</th><td bgcolor=""#FFFFFF""> <xsl:value-of select=""total2""/></td></tr>" & vbcrlf & _
		"</table>" & vbcrlf & _
		"</xsl:for-each>" & vbcrlf & _
		"<h2>Exchange Servers and corresponding AD Sites and Routinggroups</h2> " & vbcrlf & _
		"<table border=""1"" width=""100%"">" & vbcrlf & _
		"  <tr bgcolor=""#808080"">" & vbcrlf & _
		"	<th>Server:</th> " & vbcrlf & _
		"	<th>IP:</th> " & vbcrlf & _
		"	<th>AD Site:</th> " & vbcrlf & _
		"	<th>Routinggroup:</th> " & vbcrlf & _
		"  </tr>" & vbcrlf & _
		"<xsl:for-each select=""RGADMap/server""> " & vbcrlf & _
		"	<tr>" & vbcrlf & _
		"	<td>" & vbcrlf & _
		"		<xsl:value-of select=""name"" /> " & vbcrlf & _
		"	</td>" & vbcrlf & _
		"	<td>" & vbcrlf & _
		"		<xsl:value-of select=""ip"" /> " & vbcrlf & _
		"	</td>" & vbcrlf & _
		"	<xsl:choose>" & vbcrlf & _
		"		<xsl:when test=""adsite = 'NOSITE'"">" & vbcrlf & _
		"			<td bgcolor=""#FF6666"">" & vbcrlf & _
		"			<xsl:value-of select=""adsite"" />" & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>" & vbcrlf & _
		"		<xsl:when test=""adsite = 'NOPING'"">" & vbcrlf & _
		"			<td bgcolor=""#FFFF66"">" & vbcrlf & _
		"			<xsl:value-of select=""adsite"" />" & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>" & vbcrlf & _
		"		<xsl:otherwise>" & vbcrlf & _
		"			<td bgcolor=""#c0ffc0"">" & vbcrlf & _
		"			<xsl:value-of select=""adsite"" />" & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:otherwise>" & vbcrlf & _
		"	</xsl:choose>" & vbcrlf & _
		"	<td>" & vbcrlf & _
		"		<xsl:value-of select=""rg"" /> " & vbcrlf & _
		"	</td>" & vbcrlf & _
		"	</tr>" & vbcrlf & _
		"</xsl:for-each>" & vbcrlf & _
		"</table>" & vbcrlf & _
		"</body>" & vbcrlf & _
		"</html>" & vbcrlf & _
		"</xsl:template>" & vbcrlf & _
		"</xsl:stylesheet>"

	Const ForWriting = 2
	dim fs, file
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set file = fs.OpenTextFile(strfilename, ForWriting, True)
	file.writeline Convert2Text(txtxsl)
	file.Close
end sub

' ==================================================  Auxilary procedures and classes ==========================

class ADCache
' Small class to store all AD Results in a dictionary für caching these results.
' So i have not to do all that stuff in the main code and can use "straight forward development
' and still have sufficient performance

  dim dicADCache
  dim strCurrentDN
  dim objAD

	private Sub Class_Initialize
		set dicADCache = CreateObject("Scripting.dictionary")
		strCurrentDN = ""
	End Sub

	private Sub Class_Terminate
		set dicADCache = nothing
	End Sub
	
    sub Flush
		dicADCache.removeall
    end sub
	
    function getProperty(strDN, strProperty)
        dim value
        if not dicADCache.exists (strDN & "!MSXFAQ!" & strProperty) then
            if strDN <> strCurrentDN then  ' bind requested object'
                ''            wscript.echo "Bind:LDAP://" & strDN
                set objAD = GetObject("LDAP://" & strDN)
                strCurrentDN = strDN
            end if
            on error resume next
            value = objAD.get(strProperty)
            if err then
              value = "NOT FOUND"
                  err.clear
            end if
            on error goto 0
            dicADCache.add strDN & "!MSXFAQ!" & strProperty, value
        end if
        getProperty = dicADCache(strDN & "!MSXFAQ!" & strProperty)
    end function

    function getDirectProperty(strDN, strProperty)  ' read wihtout cache also für arrays
        strCurrentDN = strDN
        'wscript.echo "Bind:LDAP://" & strDN
        set objAD = GetObject("LDAP://" & strDN)
        on error resume next
        getDirectProperty = objAD.getex(strProperty)
        if err then
           getDirectProperty = "NOT FOUND"
           err.clear
        end if
        on error goto 0
    end function

    function getArrayProperty(strDN, strProperty)  ' read arrays
        dim temp
        if strDN <> strCurrentDN then  ' bind requested object'
''            wscript.echo "Bind:LDAP://" & strDN
            set objAD = GetObject("LDAP://" & strDN)
            strCurrentDN = strDN
        end if
''        wscript.echo "strProperty" & strProperty
''        wscript.echo "strDN" & strDN
        on error resume next
        temp = objAD.getex(strProperty)
        on error goto 0
        select case vartype (temp)
            case vbarray, vbarray + vbvariant, vbarray + vbstring
                getArrayProperty = temp
            case vbstring
                getArrayProperty = array(temp)
            case vbempty, vbnull
                getArrayProperty = array("")
            case else
                getArrayProperty = array("")
        end select
    end function

end class


class ADSites
' Easy access to AD-Sitekonfiguration
    dim strRootDSE, oConnection, oRecordset, oCommand
    dim dictSubnet 'Contains IP-Networks and corresponding siteDN
    dim dictSites  'contains siteDN and shortname
    dim dictDC    'contains DCs
    dim dictSiteLink    ' key= DN
    dim dictSiteLinkBridge    ' key= DN

	private Sub Class_Initialize
        set dictSubnet = createobject("Scripting.dictionary")
        set dictSites = createobject("Scripting.dictionary")
        set dictDC = createobject("Scripting.dictionary")
        set dictSiteLink = createobject("Scripting.dictionary")
        set dictSiteLinkBridge =createobject("Scripting.dictionary")
    	set strRootDSE = GetObject ("LDAP://rootDSE")
        call fillsites
        call fillsubnet
        call fillDC
        call fillSitelink
        call fillsitelinkbridge
	End Sub

	'private Sub Class_Terminate
	'End Sub

    private sub FillSites   'Fills internals data strukture'
        ' Load dictionary Object with DN and Sitename'
        dim oConnection, objRecordset, oCommand
        dim count
        objDebug.writeln "Querying AD für Sites" & strRootDSE.get ("configurationNamingContext") ,6
        Set oConnection = CreateObject("ADODB.Connection")
        Set objRecordset = CreateObject("ADODB.Recordset")
        Set oCommand = CreateObject("ADODB.Command")
        oConnection.Provider = "ADsDSOObject"
        oConnection.Open "ADs Provider"
        oCommand.ActiveConnection = oConnection
        oCommand.Properties("Page Size") = 100
        oCommand.CommandText = "<LDAP://CN=Sites," & strRootDSE.get("configurationNamingContext") & ">;" _
        				& "(objectClass=site);"_
        				& "distinguishedName,name;subtree"
        Set objRecordset = oCommand.Execute
        objDebug.writeln "Done Total ADSites found:" & objRecordset.recordcount, 6
        count = 0
        do until objRecordset.EOF
            count = count + 1
        	objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6
            dictSites.add objRecordset.Fields("distinguishedName").value, objRecordset.Fields("name").value
            objRecordset.MoveNext
        loop
        objdebug.writeln "ADSites loaded items " & count,0
    end sub

    private sub FillSubnet   'Fills internals data strukture'
        dim oConnection, objRecordset, oCommand
        dim count

        objDebug.writeln "Querying AD für Subnets" & strRootDSE.get ("configurationNamingContext") ,6
        Set oConnection = CreateObject("ADODB.Connection")
        Set objRecordset = CreateObject("ADODB.Recordset")
        Set oCommand = CreateObject("ADODB.Command")
        oConnection.Provider = "ADsDSOObject"
        oConnection.Open "ADs Provider"
        oCommand.ActiveConnection = oConnection
        oCommand.Properties("Page Size") = 100
        oCommand.CommandText = "<LDAP://CN=Subnets,CN=Sites," & strRootDSE.get ("configurationNamingContext") & ">;" _
        				& "(objectClass=subnet);"_
        				& "cn,distinguishedName,siteObject;subtree"
        Set objRecordset = oCommand.Execute
        objDebug.writeln "Done Total Subnets found:" & objRecordset.recordcount, 6
        count = 0
        do until objRecordset.EOF
            count =  count + 1
        	objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6
            dictSubnet.add objRecordset.Fields("cn").value,objRecordset.Fields("siteObject").value
            objRecordset.MoveNext
        loop
        objdebug.writeln "ADSubnets loaded items " & count,0
    end sub

    private sub FillDC  'Fills internals data strukture'
        dim oConnection, objRecordset, oCommand
        dim count

        objDebug.writeln "Querying AD für Subnets" & strRootDSE.get ("configurationNamingContext") ,6
        Set oConnection = CreateObject("ADODB.Connection")
        Set objRecordset = CreateObject("ADODB.Recordset")
        Set oCommand = CreateObject("ADODB.Command")
        oConnection.Provider = "ADsDSOObject"
        oConnection.Open "ADs Provider"
        oCommand.ActiveConnection = oConnection
        oCommand.Properties("Page Size") = 100
        oCommand.CommandText = "<LDAP://CN=Subnets,CN=Sites," & strRootDSE.get ("configurationNamingContext") & ">;" _
        				& "(objectClass=subnet);"_
        				& "cn,distinguishedName,siteObject;subtree"
        Set objRecordset = oCommand.Execute
        objDebug.writeln "Done Total Subnets found:" & objRecordset.recordcount, 6
        count = 0
        do until objRecordset.EOF
            count =  count + 1
        	objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6
            dictDC.add objRecordset.Fields("cn").value,objRecordset.Fields("siteObject").value
            objRecordset.MoveNext
        loop
        objdebug.writeln "DC loaded items " & count,0
    end sub


   private sub FillSitelink  'Fills internals data strukture'
        dim oConnection, objRecordset, oCommand
        dim count

        objDebug.writeln "Querying AD für dictSiteLink" & strRootDSE.get ("configurationNamingContext") ,6
        Set oConnection = CreateObject("ADODB.Connection")
        Set objRecordset = CreateObject("ADODB.Recordset")
        Set oCommand = CreateObject("ADODB.Command")
        oConnection.Provider = "ADsDSOObject"
        oConnection.Open "ADs Provider"
        oCommand.ActiveConnection = oConnection
        oCommand.Properties("Page Size") = 100
        oCommand.CommandText = "<LDAP://CN=Inter-Site Transports,CN=Sites," & strRootDSE.get("configurationNamingContext") & ">;" _
        				& "(objectClass=sitelink);"_
        				& "cn,distinguishedName;subtree"
        Set objRecordset = oCommand.Execute
        objDebug.writeln "Done Total dictSiteLink found:" & objRecordset.recordcount, 6
        count = 0
        do until objRecordset.EOF
            count =  count + 1
        	objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6
            dictSiteLink.add objRecordset.Fields("distinguishedName").value,objRecordset.Fields("cn").value
            objRecordset.MoveNext
        loop
        objdebug.writeln "dictSiteLink loaded items " & count,0
    end sub

   private sub FillSitelinkBridge  'Fills internals data strukture'
        dim oConnection, objRecordset, oCommand
        dim count

        objDebug.writeln "Querying AD für dictSiteLinkBrid  ge" & strRootDSE.get ("configurationNamingContext") ,6
        Set oConnection = CreateObject("ADODB.Connection")
        Set objRecordset = CreateObject("ADODB.Recordset")
        Set oCommand = CreateObject("ADODB.Command")
        oConnection.Provider = "ADsDSOObject"
        oConnection.Open "ADs Provider"
        oCommand.ActiveConnection = oConnection
        oCommand.Properties("Page Size") = 100
        oCommand.CommandText = "<LDAP://CN=Inter-Site Transports,CN=Sites," & strRootDSE.get("configurationNamingContext") & ">;" _
        				& "(objectClass=sitelinkBridge);"_
        				& "cn,distinguishedName;subtree"
        Set objRecordset = oCommand.Execute
        objDebug.writeln "Done Total dictSiteLink found:" & objRecordset.recordcount, 6
        count = 0
        do until objRecordset.EOF
            count =  count + 1
        	objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6
            dictSiteLinkBridge.add objRecordset.Fields("distinguishedName").value,objRecordset.Fields("cn").value
            objRecordset.MoveNext
        loop
        objdebug.writeln "dictSiteLinkBridge loaded items " & count,0
    end sub
    
    
    function getsitelistDN         ' Returns a Array with all Site DNs'
        getsitelistDN = dictSites.keys
	end function

    function getsitelist          ' Returns a Array with all Site names'
        getsitelist = dictSites.items
	end function

    function GetSiteName(strsite)        ' Returns the name für a siteDN
        GetSiteDN = dictSites.item(strsite)
	end function

    function getsubnetlist        ' Returns a Array with all subnets'
        getsubnetlist = dictSubnet.keys
	end function

    function getsitelinkListDN       ' Returns a Array with all Sitelinks'
        getsitelinkListDN = dictSiteLink.keys
	end function

    function getsitelinkBridgeListDN       ' Returns a Array with all Sitelinks'
        getsitelinkBridgeListDN = dictSiteLinkBridge.keys
	end function

    function GetSiteforIP (byval IPaddress)  ' returns sitename für IP-Address'
    ' result is the AD Sitename für a given ip address'
    ' Based on IP2Site.vbs witten April 4, 2003 by Wayne Tilton

        Dim DecIPAddr, MaskBits, NumAddrs, LoIPAddr, HiIPAddr, SiteAddrs
        Dim SubnetContainer, Subnet
        dim SiteName

        sitename = "NOSITE"          ' Default site name if no matches
        SiteAddrs = (2^31)-1                          ' Really big range
        DecIPAddr = Dot2Dec(IPaddress)  ' Convert supplied  address to decimal

        für each subnet in dictsubnet.keys
            MaskBits = Split(Subnet,"/")               ' Split IP addr from subnet mask
            NumAddrs = (2 ^ (32 - MaskBits(1))) - 1    ' Calc # addresses based on subnet mask
            LoIPAddr = Dot2Dec(MaskBits(0))            ' Get low end of IP range in decimal
            HiIPAddr = LoIPAddr + NumAddrs             ' Calc high end of range by adding # add
            '  Check to see if IP is within this subnet range and if so that it's smallest subnet with that addr
            If DecIPAddr => LoIPAddr And DecIPAddr <= HiIPAddr And NumAddrs <= SiteAddrs then
                SiteName = dictsubnet.item(subnet)
                SiteName = dictsites.item(Sitename)
                SiteAddrs = NumAddrs                    ' Remember # addrs in this subnet
            End If
        next
        GetSiteforIP = SiteName
    End Function


    
    private Function Dot2Dec(IPAddress) 'PRIVATE ' Returns the decimal value of a dotted decimal IP address
       Dim Octets
       Octets = Split(IPAddress,".")
       Dot2Dec = (Octets(0)*(2^24)) + (Octets(1)*(2^16)) + (Octets(2)*(2^8)) + Octets(3)
    End Function


end class



class MSXFAQExchange
' Easy access to Exchange data
    dim strRootDSE, oConnection, oRecordset, oCommand
    dim dictAG  'Contains AD and corresponding DN
    dim dictRG  'Contains RG and corresponding DN
    dim dictServer 'Contains Server and corresponding DN
    dim dictRGMember ' contains Servername and Routinggroup
    
	private Sub Class_Initialize
        set dictAG = createobject("Scripting.dictionary")
        set dictRG = createobject("Scripting.dictionary")
        set dictServer = createobject("Scripting.dictionary")
        set dictRGMember = createobject("Scripting.dictionary")
    	set strRootDSE = GetObject ("LDAP://rootDSE")
        call fillAG
        call fillRG
        call fillServer
	End Sub

	'private Sub Class_Terminate
	'End Sub

    private sub FillAG
        ' Load dictionary Object with DN and Sitename'
        dim oConnection, objRecordset, oCommand
        dim count
        objDebug.writeln "Querying AD für AG" & strRootDSE.get ("configurationNamingContext") ,6
        Set oConnection = CreateObject("ADODB.Connection")
        Set objRecordset = CreateObject("ADODB.Recordset")
        Set oCommand = CreateObject("ADODB.Command")
        oConnection.Provider = "ADsDSOObject"
        oConnection.Open "ADs Provider"
        oCommand.ActiveConnection = oConnection
        oCommand.Properties("Page Size") = 100
        
        oCommand.CommandText = "<LDAP://CN=Administrative Groups,CN=INA,CN=Microsoft Exchange,CN=Services," & strRootDSE.get("configurationNamingContext") & ">;" _
        				& "(objectClass=msExchAdminGroup);"_
        				& "distinguishedName,name;subtree"
        Set objRecordset = oCommand.Execute
        objDebug.writeln "Done Total Admingroups found:" & objRecordset.recordcount, 6
        count = 0
        do until objRecordset.EOF
            count = count + 1
        	objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6
            dictAG.add objRecordset.Fields("distinguishedName").value, objRecordset.Fields("Name").value
            objRecordset.MoveNext
        loop
        objdebug.writeln "dictAG loaded " & count,0
    end sub

    private sub FillRG
        ' Load dictionary Object with DN and Sitename'
        dim oConnection, objRecordset, oCommand
        dim count, server
        dim objRG, temp
        
        objDebug.writeln "Querying AD für RG" & strRootDSE.get ("configurationNamingContext") ,6
        Set oConnection = CreateObject("ADODB.Connection")
        Set objRecordset = CreateObject("ADODB.Recordset")
        Set oCommand = CreateObject("ADODB.Command")
        oConnection.Provider = "ADsDSOObject"
        oConnection.Open "ADs Provider"
        oCommand.ActiveConnection = oConnection
        oCommand.Properties("Page Size") = 100

        oCommand.CommandText = "<LDAP://CN=Administrative Groups,CN=INA,CN=Microsoft Exchange,CN=Services," & strRootDSE.get("configurationNamingContext") & ">;" _
        				& "(objectClass=msExchRoutingGroup);"_
        				& "distinguishedName,name;subtree"
        Set objRecordset = oCommand.Execute
        objDebug.writeln "Done Total Admingroups found:" & objRecordset.recordcount, 6
        count = 0
        do until objRecordset.EOF
            count = count + 1
        	objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6
            dictRG.add objRecordset.Fields("distinguishedName").value, objRecordset.Fields("Name").value

            ' Build Server to Routinggroup'
            set objRG = GetObject("LDAP://" & objRecordset.Fields("distinguishedName").value)
            on error resume next
            temp = objRG.get("msExchRoutingGroupMembersBL")
            if err then
                err.clear
            else
                select case vartype (temp)
                    case vbarray, vbarray + vbvariant, vbarray + vbstring
                        für each server in temp
                            dictRGMember.add server, objRecordset.Fields("distinguishedName").value
                        next
                    case vbstring
                        dictRGMember.add temp, objRecordset.Fields("distinguishedName").value
                    case else
                end select
            end if
            on error goto 0
            objRecordset.MoveNext
        loop
        objdebug.writeln "dictRG loaded " & count,0
    end sub

    private sub FillServer
        ' Load dictionary Object with DN and Sitename'
        dim oConnection, objRecordset, oCommand
        dim count
        objDebug.writeln "Querying AD für Sites" & strRootDSE.get ("configurationNamingContext") ,6
        Set oConnection = CreateObject("ADODB.Connection")
        Set objRecordset = CreateObject("ADODB.Recordset")
        Set oCommand = CreateObject("ADODB.Command")
        oConnection.Provider = "ADsDSOObject"
        oConnection.Open "ADs Provider"
        oCommand.ActiveConnection = oConnection
        oCommand.Properties("Page Size") = 100

        oCommand.CommandText = "<LDAP://CN=Administrative Groups,CN=INA,CN=Microsoft Exchange,CN=Services," & strRootDSE.get("configurationNamingContext") & ">;" _
        				& "(&(objectClass=msExchExchangeServer)(!(objectClass=msExchExchangeServerPolicy)));"_
        				& "distinguishedName,name;subtree"
        Set objRecordset = oCommand.Execute
        objDebug.writeln "Done Total Admingroups found:" & objRecordset.recordcount, 6
        count = 0
        do until objRecordset.EOF
            count = count + 1
        	objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6
            dictServer.add objRecordset.Fields("distinguishedName").value, objRecordset.Fields("name").value
            objRecordset.MoveNext
        loop
        objdebug.writeln "dictServer loaded " & count,0
    end sub

    function getAllServerListDN
        getAllServerListDN = dictServer.keys
	end function

    function getServerName (ServerDN)
        getServerName = dictServer.item(ServerDN)
	end function

    function getRGlist
        getRGlist = dictRG.keys
	end function

    function getRGMembership(serverDN)
        getRGMembership = dictRGMember.item(serverDN)
	end function

    function getAGList
        getAGList = dictAG.keys
	end function

end class


class XMLTextWriter
'~ Version 2.2
'~ usage in VBScript. Please define StyleSheet and filename first and than start writing the data
'~ set xmlWriter = new XmlTextWriter
'~ xmlWriter.filename = "filename.xml"
'~ xmlWriter.Indentation = 4
'~ call xmlWriter.WriteStylesheet("stylesheet.xsl")
'~ call xmlWriter.WriteStartElement("Root")
'~ call xmlWriter.WriteElementString("starttime", now())
'~ call xmlWriter.WriteEndElement
'~ call xmlWriter.close

	dim xmlfilename	'stores the filename
	dim xmldom  	'DOM Object
	dim xmlparent	'currentNode
	dim xmlroot		'RootNode
	dim xmlobject	'PArent of currentNode
	dim intIndentation

	'~ xmlfile.write "<?xml version='1.0' encoding='ISO-8859-1'?>" & vbcrlf

	private Sub Class_Initialize
		dim xmldeclaration
		Set xmlDom = CreateObject("Microsoft.XMLDOM")
		xmlDom.loadxml "<?xml version='1.0'?>"
		set xmlobject = xmlDom
	End Sub

	private Sub Class_Terminate
		xmldom.LoadXML getFormattedXML
		xmldom.save(xmlfilename)
	End Sub
	
	public Property let filename(wert)    
		xmlfilename = wert
	End Property

	public Property get filename
		filename = xmlfilename 
	End Property

	public Property let Indentation(wert)
		' only für Backwards compatibility
	End Property

	public Property let Formatting(wert)
		' writer.Formatting = Formatting.Indented   ' Funktioniert nur mit .nEtg ?
	End Property

	sub Writestylesheet (item)
		dim stylePI 
		Set stylePI = xmlDom.createProcessingInstruction("xml-stylesheet", "type=""text/xsl"" href="""&item & """")
		xmlDom.appendChild(stylePI)
	end sub

	sub WriteStartElement(item)
		dim xmlobject2
		set xmlobject2 = xmlDom.createElement(item)
		xmlobject.appendchild xmlobject2
		set xmlobject = xmlobject2
	end sub


	sub WriteAttributeString(name, byval value)  ' erg&auml;nzt eine ID zum aktuellen Element
		if isnull(value) then value = ""
		xmlobject.setAttribute name, value
	end sub
	

	sub WriteElementString(item, byval value)  ' add XML tag and Data
		dim xmldata
		set xmldata = xmlDom.createElement(item)
		if isnull(value) then value = ""
		xmldata.text = value
		xmlobject.appendchild(xmldata)
	end sub
	
	sub WriteEndElement
	' Schliesse den aktuellen Client und gehe ein objekt h&ouml;her
		set xmlobject = xmlobject.parentnode
	end sub

	sub DeleteEndElement
	' Entferne den letzten Client komplett
		dim xmlobject2
		set xmlobject2 = xmlobject
		set xmlobject = xmlobject.parentnode
		xmlobject.removechild(xmlobject2)
	end sub


	function getXML
	' gebe die aktuelle XML-Information unformtiert aus
		getxml = xmldom.xml
	end function

	function LoadXML(strxml)
	' ersetze die Information durch eine neue XML-Information
		xmldom.loadXML(strxml)
	end function

	sub Flush()
	' Schreibe die aktuelle XML-Struktur als Datei heraus
		'~ xmldom.LoadXML getFormattedXML   ' wenn dsa aktiv wird, ist die XML Datei nicht komplett
		xmldom.save(xmlfilename)
	end sub


	function getFormattedXML
	' Gebe die XML-Struktur formatiert und besser lesbar aus
		dim oStylesheet
		set oStylesheet = CreateObject("Microsoft.XMLDOM")
		oStylesheet.async = False
		oStylesheet.loadXML ("<?xml version=""1.0"" encoding=""UTF-8""?>" & vbcrlf & _
						"<xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"">" & vbcrlf & _
						"<xsl:output method=""xml"" indent=""yes"" encoding=""UTF-8"" />" & vbcrlf & _
						"<xsl:template match=""@* | node()"">" & vbcrlf & _
						"   <xsl:copy>" & vbcrlf & _
						"        <xsl:apply-templates select=""@* | node()"" />" & vbcrlf & _
						"   </xsl:copy>" & vbcrlf & _
						"</xsl:template>" & vbcrlf & _
						"</xsl:stylesheet>")
		getFormattedXML = xmlDOM.transformNode(oStylesheet)
	end function


	sub close()
		xmldom.LoadXML getFormattedXML
		xmldom.save(xmlfilename)
	end sub
	
end class



class debugwriter
	' Generic Class für writing debugging information and handling runtime errors
	' By default al Level 1 Messaegs are logged to the Console
	' Version 29. Mar 2006

	private objIE, file, fs, debugfilename, status, strline
	private debuglevelIE , debuglevelfile, debugleveleventlog, debuglevelConsole

	private Sub Class_Initialize
		status = "active" : strline = "" : debugfilename = ""
		debuglevelIE = 0
		debuglevelfile = 0
		debugleveleventlog = 0
		debuglevelConsole = 1
	End Sub

	private Sub Class_Terminate()
		if isobject(OBJIE) then
			objie.document.write "</table></body></html>"
		end if
		if debugfilename <> "" then
			file.Close
		end if
	End Sub

	public sub start : status = "active": end sub
	public sub pause : status = "pause" : end sub

	public property let outfile(wert) 	
		if debugfilename <> "" then    'Close existing debug file
			file.close : file = nothing : fs = nothing 
		end if

		debugfilename = wert    ' open debug file
		Set fs = CreateObject("Scripting.FileSystemObject")
		Set file = fs.OpenTextFile(makefilename(debugfilename), 8, True)
	end property

	public property let setie (wert)  : set objIE = wert  : objie.visible = true  end property

	public property let target (wert)
		dim arrTemp, intcount
		arrTemp = split(wert," ")  ' spit by space
		for intcount = 0 to ubound(arrTemp)
			select case lcase(split(arrtemp(intcount),":")(0))
				case "ie" 		debuglevelIE = cint(right(arrtemp(intcount),1))
				case "file" 	debuglevelfile = cint(right(arrtemp(intcount),1))
				case "eventlog" debugleveleventlog = cint(right(arrtemp(intcount),1))
				case "console" 	debuglevelConsole = cint(right(arrtemp(intcount),1))
			end select
		next
	end property

	sub write(strMessage)  
		strline = strline & strMessage
	end sub

	Sub writeln(strMessage, intseverity)
	'Fügt einen Eintrag in die Log-Datei ein
		dim blnerror
		
		strMessage = strline & strMessage  ' add existing Output Messages
		strline = ""
		
		if err <> 0 then  ' Sonderbehandlung als "ErrorHandler"
			blnerror = true
			strmessage= "RUNTIME ERROR  :" & strMessage & vbcrlf & _
						"ERR.Number     :" & err.number & vbcrlf & _
						"ERR.Description:" & err.Description & vbcrlf & _
						"ERR.Source     :" & err.source & vbcrlf & _
						"ERR.HelpFile   :" & err.HelpFile & vbcrlf & _
						"ERR.HelpContext:" & err.HelpContext & vbcrlf
			err.clear
		else
			blnerror = false
		end if
	
		if ((status = "active")  or blnerror) then 

		if (debuglevelfile > 0) and ((debuglevelfile >= intseverity) or blnerror) and (debugfilename <> "") then
                file.Write(Now & ",")
                Select Case intseverity
                    Case 0  file.Write("Out0")
                    Case 1  file.Write("Err1")
                    Case 2  file.Write("Wrn2")
                    Case 3  file.Write("Inf3")
                    Case Else file.Write("Dbg"&intseverity)
                End Select
                file.WriteLine("," & Convert2Text(strMessage))
		strline = ""
            end if

		if (debugleveleventlog > 0) and ((debugleveleventlog >=intSeverity) or blnerror) then
                dim objWSHShell
		Set objWSHShell = Wscript.CreateObject("Wscript.Shell")
                Select Case intseverity
			Case 0  objWSHShell.LogEvent 0, strMessage '           		Const EVENT_SUCCESS = 0
			Case 1  objWSHShell.LogEvent 1, strMessage '           		const EVENT_ERROR = 1
			Case 2  objWSHShell.LogEvent 2, strMessage '           		Const EVENT_WARNING = 2
			Case else  objWSHShell.LogEvent 4, strMessage '           	Const EVENT_INFO = 4
                End Select
			end if

			if (debuglevelconsole > 0) and ((debuglevelconsole >=intSeverity) or blnerror) then
				Select Case intseverity
					Case 0  wscript.echo now() & ",OUT0:" & strMessage
					Case 1  wscript.echo now() & ",ERR1:" & strMessage
					Case 2  wscript.echo now() & ",WRN2:" & strMessage
					Case 3  wscript.echo now() & ",INF3:" & strMessage
					Case Else wscript.echo now() & ",DBG" & intseverity & ":" & strMessage
				End Select
			end if

           if (debuglevelie > 0) and ((debuglevelie >= intSeverity) or blnerror) then
           		dim strieline
      			if  not isobject(objIE) then
      				Set objIE = CreateObject("InternetExplorer.Application")
           		    objIE.navigate("about:blank")
					objIE.visible = true
					Do While objIE.Busy
				    	WScript.Sleep 50
					Loop
					objIE.document.write "<html><head><title>DebugWriter Output</title></head><body>"
					objIE.document.write "<table  border=""1"" width=""100%""><tr><th>Time</th><th>intseverity</th><th>Description</th></tr>"
				end if
           		strieline = "<tr><td>" & now () & "</td>"
                Select Case intseverity
                    Case 0  strieline = strieLine & "<td bgcolor=""#00FF00"">Out0</td>"
                    Case 1  strieline = strieLine & "<td bgcolor=""#FF0000"">Err1</td>"
                    Case 2  strieline = strieLine & "<td bgcolor=""#FFFF00"">Wrn2</td>"
                    Case 3  strieline = strieLine & "<td>Inf3</td>"
                    Case Else strieline = strieLine & "<td>Dbg"&intseverity&"</td>"
                End Select
                strieline = strieline & "<td>" & strmessage & "</td></tr>"
				objIE.document.write cstr(strieline)
           end if

           '~ if (instr(DebugTarget,"mom") <>0) or blnerror then
				'~ scriptContext.echo now() &","& intseverity &":"& strline & strMessage
           '~ end if

		end if  ' if status = active
		strline = ""
   	End Sub
	
	
	private function makefilename(wert)
		' Converts all invalid characters to valid file names
		wert = replace(wert,"\","-")
		wert = replace(wert,"/","-")
		wert = replace(wert,":","-")
		wert = replace(wert,"*","-")
		wert = replace(wert,"?","-")
		wert = replace(wert,"<","-")
		wert = replace(wert,"|","-")
		wert = replace(wert,"""","-")
		makefilename = wert
	end function
	
	private function Convert2Text(wert) 	' Converts non printable characters to "X" , so that Textfile is working
		dim loopcount, tempwert, inttest
		tempwert=""
		for loopcount = 1 to len(wert)   ' replace all unprintable characters  maybe easier and faster with RegEx
			tempwert = tempwert & chr(ascb(mid(wert,loopcount,1)))	
		next
		Convert2Text = tempwert
	end function
	
end class

sub ForceCScript
    If InStr(1,WScript.FullName,"cscript",vbTextCompare) = 0 Then   ' Prüfung ob mit CSCRIPT gestartet wurde
        wscript.echo "Bitte mit CSCRIPT aufrufen"
        wscript.quit (255)
	end if
end sub

class WMIPing

    dim objWMIService

	private Sub Class_Initialize
        Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
	End Sub

    Function Ping(strTarget) ' Returns reply IP-Address if found
        dim colPings, objPing
        Set colPings = objWMIService.ExecQuery ("Select * From Win32_PingStatus where Address = '" & strTarget & "'")
''        wscript.echo "Ping " & strTarget
        If Err = 0 Then
            Err.Clear
            für Each objPing in colPings
                If Err = 0 Then
                    Err.Clear
                    If objPing.StatusCode = 0 Then
                        Ping = objPing.ProtocolAddress
                    Else
                        Ping = "0.0.0.0"
                    End If
                Else
                   Err.Clear
                End If
            Next
        Else
            Err.Clear
            Ping = "0.0.0.0"
        End If
    End Function
end class

function Convert2Text(wert)
	' Converts non printable characters to "X" , so that Textfile is working
	dim loopcount, tempwert, inttest
	tempwert=""
	for loopcount = 1 to len(wert)   ' replace all unprintable characters  maybe easier and faster with RegEx
		'~ inttest = ascw(mid(wert,loopcount,1))
		'~ if ((inttest>=32) and (inttest<127)) or (inttest=10) or (inttest=13) or (inttest=9) then
			'~ tempwert = tempwert & chr(inttest)  ' printable Character or CR LF TAB
		'~ else
			'~ tempwert = tempwert & "X"
		'~ end if 
		tempwert = tempwert & chr(ascb(mid(wert,loopcount,1)))	
	next
	Convert2Text = tempwert
end function

function makefilename(wert)
	' Converts all invalid characters to valid file names
	wert = replace(wert,"\","-")
	wert = replace(wert,"/","-")
	wert = replace(wert,":","-")
	wert = replace(wert,"*","-")
	wert = replace(wert,"?","-")
	wert = replace(wert,"<","-")
	wert = replace(wert,"|","-")
	wert = replace(wert,"""","-")
	makefilename = wert
end function


Function OctetToGUIDStr (arrbytOctet)
	' Function to convert OctetString (byte array) to GUID string.
	' based on Code from Richard Mueller, a MS MVP in Scripting and ADSI

	Dim k,strtemp
	OctetToGUIDStr = ""
	For k = 1 To Lenb (arrbytOctet)
		OctetToGUIDStr = OctetToGUIDStr & Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2)
	Next
	
'~ In     FB72F95DB430704983082BB1C79FFB38
'~ Out {5DF972FB-30B4-4970-8308-2BB1C79FFB38}
	
	strtemp= "{"
	strtemp = strtemp & mid(OctetToGUIDStr,7,2)
	strtemp = strtemp & mid(OctetToGUIDStr,5,2)
	strtemp = strtemp & mid(OctetToGUIDStr,3,2)
	strtemp = strtemp & mid(OctetToGUIDStr,1,2)
	strtemp = strtemp & "-"
	strtemp = strtemp & mid(OctetToGUIDStr,11,2)
	strtemp = strtemp & mid(OctetToGUIDStr,9,2)
	strtemp = strtemp & "-"
	strtemp = strtemp & mid(OctetToGUIDStr,15,2)
	strtemp = strtemp & mid(OctetToGUIDStr,13,2)
	strtemp = strtemp & "-"
	strtemp = strtemp & mid(OctetToGUIDStr,17,4)
	strtemp = strtemp & "-"
	strtemp = strtemp & mid(OctetToGUIDStr,21,12)
	OctetToGUIDStr = strtemp & "}"

End Function