Option Explicit
'-------------------------------------------------------------------------
' MBQuotaReport.vbs
'
' Beschreibung
' Holt für die ausgewählen Benutzer die aktuellen Quota einstellungen und die Daten aus dem Exchange Store
' via homeMDB  link auf  msExchOwningServer link auf name
'
' Exchange 21030 und WMI rechte auf das Zielsystem erforderlich
'
' Das Skript wird mit den Berechtigungen des angemeldeten Benutzers
' ausgeführt. Die entsprechenden Berechtigungen sind sicher zu stellen
'
' (c)2006 Net at Work Netzwerksysteme GmbH
'
' Version 1.0 (17. Mai 2006) Frank Carius
'	Initial Release
' Version 1.1 (18. Mai 2006) Frank Carius
'	Verbessertes Caching unerreichbarer Server
'	Ausgabe von "unlimited"
'	Ausgabe prozentualer Angaben
'	Umfangreiche "on error resume next" behandlungen
' Version 1.2 (22. Okt 2006) Frank Carius
'	Ausgabe der Limits, auch wenn nicht gesetzt wg Formatierung
'	Diverse Optimierungen im Code. kleinere kosmetische Korrekturen
' Version 1.2.1 (26. Jul 2007) Frank Carius
'	Debugversion aufgrund noch nicht bekannter WMI-Werte  (Debug 7)
' Version 1.2.2 (31. Jul 2007) Frank Carius
'	Erweiterung Ausgabe User ohne HomeMDB und ungültigen HomeMDB
' Version 1.3 (14 Mrz 2008) Frank Carius
'	Sonderfall User war noch nie angemeldet. abgesichert
'
' Offen
'	Erkennen ob Policy oder nicht ist noch nicht korrekt
'
' Ausgabe ca 1 Kbyte pro User als XML-Datei
'
' Hinweise
' http://msdn.microsoft.com/library/en-us/e2k3/e2k3/_wmiref_cl_Exchange_Mailbox.asp
'
' The MailboxGUID property from the WMI provider will match the msExchMailboxGuid attribute of the User object in Active Directory. 
' The same goes für the LegacyDN / legacyExchangeDN
' Erst ab Exchange 2003 !!!

'~ Download the Exchange Quota Message Service
'~ http://www.gotdotnet.com/workspaces/workspace.aspx?id=b82dabfa-8353-472c-b82b-1423263ab1bb

'~ Generate a custom Quota Message limit
'~ http://blogs.technet.com/exchange/archive/2004/04/20/117024.aspx

' Erweiterung:  
' - Trennung ob Limit auf Store ist oder per Policy kommt
'-------------------------------------------------------------------------

Dim total, strGCPath
Dim oConnection, oCommand, oRecordset
Dim strResult, strQuery, strOutFilePrefix
Dim objDebug, xmlwriter
Dim ExStore 

strOutFilePrefix = makefilename("MBQuotaReport-" & Date() & "-" & Time())  ' common name of the output files without extension
set objdebug = new DebugWriter 
objDebug.target = "file:7 console:3" ' 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 "MBQuotaReport 1.2: gestartet", 0

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

objDebug.write "Looking für GC"
dim oCont, oGC
Set oCont = GetObject("GC:")
For Each oGC In oCont
    strGCPath = oGC.ADsPath
Next
objDebug.writeln "strGCPath=" & strGCPath, 3

' Walk though all groups 

objDebug.writeln "Querying AD für Objects at " & strGCPath,4
Set oConnection = CreateObject("ADODB.Connection")
Set oRecordset = 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 = "<" & strGCPath & ">;(&(mailnickname=*)(|(&(objectCategory=person)(objectClass=User)(|(homeMDB=*)(msExchHomeServerName=*)))));distinguishedName,LegacyExchangeDN,name,mail;subtree"
Set oRecordset = oCommand.Execute
objDebug.writeln "Done Total Records found:" & oRecordset.recordcount, 0
call xmlWriter.WriteElementString("total1", oRecordset.recordcount)

call xmlWriter.WriteElementString("starttime2", now())
total = 0  
set ExStore = new ExStoreCache

dim strdn, result, size
oRecordset.MoveFirst
do until oRecordset.EOF
	total = total + 1
	objDebug.writeln "Object:" & total & "/" & oRecordset.recordcount &":" & left(oRecordset.Fields("distinguishedName"),20)&".." ,4
	objDebug.writeln "  Mail  :" & oRecordset.Fields("mail"),4
	call xmlWriter.WriteStartElement("object")   ' of ("MBQuotaReport")
	call xmlWriter.WriteElementString("name", oRecordset.Fields("name").value)
	strdn = oRecordset.Fields("distinguishedName").value
	call xmlWriter.WriteElementString("dn", strdn)
	call xmlWriter.WriteElementString("mail", oRecordset.Fields("mail"))
	call xmlWriter.WriteElementString("LegacyExchangeDN", oRecordset.Fields("LegacyExchangeDN"))
	call xmlWriter.WriteElementString("total", exstore.GetStoreData(strdn,"total"))
	size = exstore.GetStoreData(strdn,"size")
	call xmlWriter.WriteElementString("size", size)
	if isnumeric(size) then
	else
		size = -1
	end if 
	call xmlWriter.WriteElementString("deleted", exstore.GetStoreData(strdn,"deleted"))
	call xmlWriter.WriteElementString("limit", exstore.GetStoreData(strdn,"storagelimitinfo"))
	call xmlWriter.WriteElementString("limittxt", exstore.GetStoreData(strdn,"storagelimitinfotxt"))
	call xmlWriter.WriteElementString("config", exstore.GetStoreData(strdn,"config"))

	result = exstore.GetStoreData(strdn,"limit1")
	if isnumeric(result) then 
		call xmlWriter.WriteElementString("limit1", formatnumber(result/1024,1))
		call xmlWriter.WriteElementString("limit1p", formatnumber(size / result * 100,2))
	else
		call xmlWriter.WriteElementString("limit1", result)
		call xmlWriter.WriteElementString("limit1p", "NA")
	end if 

	result = exstore.GetStoreData(strdn,"limit2")
	if isnumeric(result) then 
		call xmlWriter.WriteElementString("limit2", formatnumber(result/1024,1))
		call xmlWriter.WriteElementString("limit2p", formatnumber(size / result * 100,2))
	else
		call xmlWriter.WriteElementString("limit2", result)
		call xmlWriter.WriteElementString("limit2p", "NA")
	end if 

	result = exstore.GetStoreData(strdn,"limit3")
	if isnumeric(result) then 
		call xmlWriter.WriteElementString("limit3", formatnumber(result/1024,1))
		call xmlWriter.WriteElementString("limit3p", formatnumber(size / result * 100,2))
	else
		call xmlWriter.WriteElementString("limit3", result)
		call xmlWriter.WriteElementString("limit3p", "NA")
	end if 

	call xmlWriter.WriteEndElement()   ' of ("MBQuotaReport")
	oRecordset.MoveNext
loop

objDebug.writeln "Dumping Server Dictionary",0

dim strserver, arrServer
arrServer = exstore.GetServerStatus("")  ' Get list of Servers
for each strserver in arrServer
	objDebug.writeln "Dumping Server" & strServer,5
	call xmlWriter.WriteStartElement("Server")   ' of ("MBQuotaReport")
	call xmlWriter.WriteElementString("name", strserver)
	call xmlWriter.WriteElementString("status", exstore.GetServerStatus(strserver))
	call xmlWriter.WriteEndElement()   ' of ("MBQuotaReport")
next

call xmlWriter.WriteElementString("total2", total)
call xmlWriter.WriteElementString("endtime", now())
call xmlWriter.WriteEndElement()   ' of ("MBQuotaReport")
call xmlWriter.Close               ' XML schreiben
objDebug.writeln "Finished !!!",0
WScript.quit(0)



class ExStoreCache
	'~ Klasse zum Zwischenspeichern der Ergebnisse der WMI-Abfragen in einem Dictionary
	dim dictEXStoreCache ' Dictionary  basierend auf dem LegacyExchangeDN
	dim dictEXServerCache ' Dictionary für Exchange Server abfragen
	dim dictEXLimitCache	
	dim objUser, objHomeMDB, objHomeServer
	dim strCurrentUserDN

	
	private Sub Class_Initialize
		Set dictEXStoreCache = CreateObject("Scripting.dictionary")  ' Cache für aktuelle Gr&ouml;ße der Mailboxen
		Set dictEXServerCache = CreateObject("Scripting.dictionary")  ' Cache für bereits abgefragte Server
		Set dictEXLimitCache = CreateObject("Scripting.dictionary")  ' Cache für bereits abgefragte Storage Limits
		strCurrentUserDN = ""
	End Sub

	private Sub Class_Terminate
		Set dictEXStoreCache = nothing
	End Sub

	function GetStoreData(strUserDN,Wert)
		dim strUserLegacyExchangeDN
		dim strLimit1, strLimit2, strLimit3, strConfig
		dim blnmDBUseDefaults
		dim strHomeServer, policylist 
		
		objDebug.writeln "GetStoreData: DN=" & strUserDN & " Wert="&wert, 7
		on error resume next
		if strCurrentUserDN <> strUserDN then	' Objekt nur binden, wenn erforderlich
			objDebug.writeln "GetStoreData: Bind DN=" & strUserDN, 7
			set objUser = GetObject("LDAP://" & strUserDN)
			strCurrentUserDN  = strUserDN
		else
			objDebug.writeln "GetStoreData: using already bound User object", 7
		end if 
		objDebug.writeln "GetStoreData: User Bound " & wert, 7
		if err = 0 then 
			on error goto 0
			strUserLegacyExchangeDN = lcase(objUser.LegacyExchangeDN)
			objDebug.writeln "GetStoreData: strUserLegacyExchangeDN =" & strUserLegacyExchangeDN , 7
			if not dictEXStoreCache.exists(strUserLegacyExchangeDN) then
				' via homeMDB  link auf  msExchOwningServer link auf name
				on error resume next
				set objHomeMDB = GetObject("LDAP://" & objUser.homeMDB) 
				if err <> 0 then
					objDebug.writeln "GetStoreData: unable to bind HomeMDB Object" & strUserDN, 2
					dictEXStoreCache.add lcase(strUserLegacyExchangeDN), "HomeMDBErr" & vbtab & "HomeMDBErr" & vbtab & "HomeMDBErr" & vbtab & "HomeMDBErr"
				else
					objDebug.writeln "GetStoreData: HomeMDB bound OK" & objHomeMDB.get("Name"), 7
					set objHomeServer = GetObject("LDAP://" & objHomeMDB.msExchOwningServer)
					if err <> 0 then
						objDebug.writeln "GetStoreData: unable to find Homeserver für " & strUserDN , 2
						dictEXStoreCache.add lcase(strUserLegacyExchangeDN), "HomeSRVErr" & vbtab & "HomeSRVErr" & vbtab & "HomeSRVErr" & vbtab & "HomeSRVErr"						
					else
						strHomeServer = objHomeServer.get("Name")
						objDebug.writeln "GetStoreData: HomeServer bound OK "& strHomeServer, 7

						if not dictEXServerCache.exists(strHomeServer) then  ' skip if server was already tried EARLIER
							fillDictionary(objHomeServer.get("Name"))
							objDebug.writeln "GetStoreData: FillData Result:" &dictEXServerCache.item (objHomeServer.get("Name")) , 6
						end if
						
						if dictEXServerCache.item(objHomeServer.get("Name"))  = "OK" then
							objDebug.writeln "GetStoreData: FillData OK", 5
							if not dictEXStoreCache.exists(strUserLegacyExchangeDN) then
								' Mailbox ist nicht im Store -> noch nie angemeldet
								dictEXStoreCache.add lcase(strUserLegacyExchangeDN), "0" & vbtab & "0" & vbtab & "0" & vbtab & "NewUser"
							end if
						elseif dictEXServerCache.item(objHomeServer.get("Name"))  = "WMIError" then
							objDebug.writeln "GetStoreData: FillDictionary unable to get data for:" & strUserLegacyExchangeDN, 2
							dictEXStoreCache.add lcase(strUserLegacyExchangeDN), "WMIError" & vbtab & "WMIError" & vbtab & "WMIError" & vbtab & "WMIError"
						else
							objDebug.writeln "GetStoreData: Invalid FillData Result", 1
							dictEXStoreCache.add lcase(strUserLegacyExchangeDN), "INVALID" & vbtab & "INVALID" & vbtab & "INVALID" & vbtab & "INVALID"
						end if
					end if
				end if
				on error goto 0
			end if 
			if not dictEXStoreCache.exists(strUserLegacyExchangeDN) then
				GetStoreData = "OBJ_NOTFOUND"
			else
				if (lcase(Wert) = "config")_
				or (lcase(Wert) = "limit1")_ 
				or (lcase(Wert) = "limit2")_ 
				or (lcase(Wert) = "limit3") then
					on error resume next
					blnmDBUseDefaults = objUser.get("mDBUseDefaults")
					if err then ' Assume mDBUseDefaults = true, because it's not there
						err.clear
						blnmDBUseDefaults = TRUE
					end if 
					on error goto 0
					
					if blnmDBUseDefaults = FALSE then  ' AD Einsellungen aktiv
						strConfig = "AD"
						on error resume next
						strLimit1 = objUser.Get("mDBStorageQuota")
						if err <> 0 then
							err.clear
							strLimit1 = "NA"
						end if 
						strLimit2 = objUser.Get("mDBOverQuotaLimit")
						if err <> 0 then
							err.clear
							strLimit2 = "NA"
						end if 
						strLimit3 = objUser.Get("mDBOverHardQuotaLimit")
						if err <> 0 then
							err.clear
							strLimit3 = "NA"
						end if 
						on error goto 0
					else
						if dictEXLimitCache.exists(objUser.homeMDB) then
							strConfig = split(dictEXLimitCache.item(objUser.homeMDB),"!MSXFAQ!")(0)
							strLimit1 = split(dictEXLimitCache.item(objUser.homeMDB),"!MSXFAQ!")(1)
							strLimit2 = split(dictEXLimitCache.item(objUser.homeMDB),"!MSXFAQ!")(2)
							strLimit3 = split(dictEXLimitCache.item(objUser.homeMDB),"!MSXFAQ!")(3)
						else
							on error resume next
							set objHomeMDB = GetObject("LDAP://" & objUser.homeMDB) 
							if err <> 0 then
								err.clear
								objDebug.writeln "Cannot bind HomeMDB:" & objUser.homeMDB , 1
								strLimit1 = "NoMDB"
								strLimit2 = "NoMDB"
								strLimit3 = "NoMDB"
								strConfig = "NoMDB" 
							end if 
							

							objDebug.writeln "Reading msExchPolicyList of :" & objUser.homeMDB , 7
							policylist = objHomeMDB.Get("msExchPolicyList")
							
							if err = 0 then
								objDebug.writeln "msExchPolicyList exists. Assume there is a Storage Policy at " & objUser.homeMDB , 5
								strConfig = "Policy"
								' Additional Logic required to check the details pf the policies. but i have to do that later
							else
								err.clear
								objDebug.writeln "Cannot read msExchPolicyList of HomeMDB:" & objUser.homeMDB , 5
								strConfig = "MBStore" 
								strLimit1 = objHomeMDB.Get("mDBStorageQuota")
								if err <> 0 then strLimit1 = "NA"
								err.clear

								strLimit2 = objHomeMDB.Get("mDBOverQuotaLimit")
								if err <> 0 then strLimit2 = "NA"
								err.clear
								
								strLimit3 = objHomeMDB.Get("mDBOverHardQuotaLimit")
								if err <> 0 then strLimit3 = "NA"
								err.clear
							end if 
						
							on error goto 0
							objDebug.writeln "EXLimitCache ADD:" & objUser.homeMDB & " VALUE:" & strConfig & "!MSXFAQ!" & strLimit1 & "!MSXFAQ!" & strLimit2 & "!MSXFAQ!" & strLimit3 , 6
							dictEXLimitCache.add objUser.homeMDB, strConfig & "!MSXFAQ!" & strLimit1& "!MSXFAQ!" &strLimit2& "!MSXFAQ!" &strLimit3
						end if
					end if
				end if
				
				select case lcase(Wert)
					case "total" : GetStoreData  =  split(dictEXStoreCache.item (strUserLegacyExchangeDN),vbtab)(0)
					case "size" : GetStoreData  =  split(dictEXStoreCache.item (strUserLegacyExchangeDN),vbtab)(1)
					case "deleted" : GetStoreData  =  split(dictEXStoreCache.item (strUserLegacyExchangeDN),vbtab)(2)
					case "storagelimitinfo" : GetStoreData  =  split(dictEXStoreCache.item (strUserLegacyExchangeDN),vbtab)(3)
					case "storagelimitinfotxt" : 				
								select case split(dictEXStoreCache.item (strUserLegacyExchangeDN),vbtab)(3)
									case "1" GetStoreData  =  "Unter Limit"
									case "2" GetStoreData  =  "Warnung ausgeben"
									case "4" GetStoreData  =  "Senden verbieten"
									case "8" GetStoreData  =  "KEIN Limit"
									case "16" GetStoreData =  "Empfangen verhindert"
									case "NewUser" GetStoreData =  "NewUser"
									case else GetStoreData = "BAD_LIMIT:"& split(dictEXStoreCache.item (strUserLegacyExchangeDN),vbtab)(3)
								end select
					case "config": GetStoreData = strConfig  '"AD"
					case "limit1" : GetStoreData = strLimit1	'oUser.Get("mDBStorageQuota"))
					case "limit2" : GetStoreData = strLimit2	'oUser.Get("mDBOverQuotaLimit"))
					case "limit3" : GetStoreData = strLimit3	'oUser.Get("mDBOverHardQuotaLimit"))
					case else GetStoreData = "INVALID_PARAM"
				end select
			end if
		else
			GetStoreData = "Unable to Bind Userobject"
			objDebug.writeln "GetStoreData: unable to Bind Userobject" & strUserDN , 2
		end if
		on error goto 0
	end function

	private sub FillDictionary(strServername)

		Dim strWinMgmts		' Connection string für WMI
		Dim objWMIExchange	' Exchange Namespace WMI object
		Dim listExchange_Mailboxs	' ExchangeLogons collection
		Dim objExchange_Mailbox		' A single ExchangeLogon WMI object
		dim intCount, inttotal 

		objDebug.writeln "FillDictionary Servername:" & strServername, 4
		objDebug.writeln "Connecting to WMI:" & strServername, 6
		on error resume next
		Set objWMIExchange =  GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strServername & "/root/MicrosoftExchangeV2")
		' Verify we were able to correctly set the object.
		If Err.Number <> 0 Then
			objDebug.writeln "ERROR: unable to connect to the WMI namespace.:" & strServername, 1
			dictEXServerCache.add strServername, "WMIError"
			err.clear
			on error goto 0
		Else
			on error goto 0
			dictEXServerCache.add strServername, "OK"
			Set listExchange_Mailboxs = objWMIExchange.InstancesOf("Exchange_Mailbox")
			objDebug.writeln "FillDictionary: Reading Mailboxdata of " & listExchange_Mailboxs.count & " Mailboxes", 0
			inttotal = listExchange_Mailboxs.count
			If inttotal > 0 Then
				intcount = 0 : 
				For Each objExchange_Mailbox in listExchange_Mailboxs
					intcount = intcount + 1
					if not dictEXStoreCache.exists(lcase(objExchange_Mailbox.LegacyDN)) then
						objDebug.writeln "EXCache add " & intcount & "/" & inttotal &":" & lcase(objExchange_Mailbox.LegacyDN), 6
						dictEXStoreCache.add lcase(objExchange_Mailbox.LegacyDN), objExchange_Mailbox.TotalItems & vbtab &_
															  objExchange_Mailbox.Size & vbtab &_ 
															  objExchange_Mailbox.DeletedMessageSizeExtended & vbtab &_ 
															  objExchange_Mailbox.StorageLimitInfo
						objDebug.writeln "EXCache add LegacyDN:" & objExchange_Mailbox.LegacyDN ,7
						objDebug.writeln "EXCache add LegacyDN:" & objExchange_Mailbox.TotalItems ,7 
						objDebug.writeln "EXCache add Size:" & objExchange_Mailbox.Size ,7 
						objDebug.writeln "EXCache add DeletedMessagesSite:" & objExchange_Mailbox.DeletedMessageSizeExtended ,7 
						objDebug.writeln "EXCache add StorageLimitInfo:" & objExchange_Mailbox.StorageLimitInfo ,7
					else
						objDebug.writeln "EXCache alreadyExists " & lcase(objExchange_Mailbox.LegacyDN), 2
					end if 
				Next
			Else
				objDebug.writeln "WARNING: No Exchange_Mailbox instances were returned.", 2
			End If
		End If
		objDebug.writeln "FillDictionary Done:" & strServername, 6
	end sub

	function GetServerStatus(strServername)
		if strServername = "" then 
			GetServerStatus = dictEXServerCache.keys
		else
			GetServerStatus = dictEXServerCache.item(strServername)
		end if
	end function

end class




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>MBQuotaReport Status</title></head>" & vbcrlf & _
		"<body>" & vbcrlf & _
		"<h1>MBQuotaReport Status</h1> " & vbcrlf & _
		"<h2>Summary</h2> " & vbcrlf & _
		"<xsl:for-each select=""MBQuotaReport""> " & vbcrlf & _
		"<table border=""1"" width=""100%"">" & vbcrlf & _
		"	<tr><th>Starttime 1</th><td><xsl:value-of select=""starttime1"" /></td></tr>" & vbcrlf & _
		"	<tr><th>Starttime 2</th><td><xsl:value-of select=""starttime2"" /></td></tr>" & vbcrlf & _
		"	<tr><th>EndTime</th> <td><xsl:value-of select=""endtime"" /></td></tr>" & vbcrlf & _
		"	<tr><th># Objects found</th><td bgcolor=""#FFFFFF""><xsl:value-of select=""total1""/></td></tr>" & vbcrlf & _
		"	<tr><th># Objects processed</th><td bgcolor=""#FFFFFF""><xsl:value-of select=""total2""/></td></tr>" & vbcrlf & _
		"</table>" & vbcrlf & _
		"</xsl:for-each>" & vbcrlf & _
		"<h2>Details</h2> " & vbcrlf & _
		"<table border=""1"" width=""100%"">" & vbcrlf & _
		"  <tr bgcolor=""#808080"">" & vbcrlf & _
		"	<th>Objectname:</th> " & vbcrlf & _
		"	<th>Mail:</th> " & vbcrlf & _
		"	<th>MBSize</th> " & vbcrlf & _
		"	<th>Current Status</th> " & vbcrlf & _
		"	<th>Source</th> " & vbcrlf & _
		"	<th>ADLimit in MB</th> " & vbcrlf & _
		"	<th>% usage</th> " & vbcrlf & _
		"  </tr>" & vbcrlf & _
		"<xsl:for-each select=""MBQuotaReport/object""> " & vbcrlf & _
		"	<xsl:sort select=""memberrec"" data-type=""number"" order=""descending""/>" & vbcrlf & _
		"	<tr>" & vbcrlf & _
		"	<td>" & vbcrlf & _
		"		<xsl:value-of select=""name"" /> " & vbcrlf & _
		"	</td>" & vbcrlf & _
		"	<td>" & vbcrlf & _
		"		<xsl:value-of select=""mail"" /> " & vbcrlf & _
		"	</td>" & vbcrlf & _
		"	<td>" & vbcrlf & _
		"		<xsl:value-of select=""size"" /> " & vbcrlf & _
		"	</td>" & vbcrlf & _
		"	<xsl:choose>" & vbcrlf & _
		"		<xsl:when test=""limit='1'"">" & vbcrlf & _
		"			<td bgcolor=""#80ff80"">" & vbcrlf & _
		"			<xsl:value-of select=""limittxt"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>  " & vbcrlf & _
		"		<xsl:when test=""limit='2'"">" & vbcrlf & _
		"			<td bgcolor=""#ffff00"">" & vbcrlf & _
		"			<xsl:value-of select=""limittxt"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>  " & vbcrlf & _
		"		<xsl:when test=""limit='4'"">" & vbcrlf & _
		"			<td bgcolor=""#ffff00"">" & vbcrlf & _
		"			<xsl:value-of select=""limittxt"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>  " & vbcrlf & _
		"		<xsl:when test=""limit='8'"">" & vbcrlf & _
		"			<td bgcolor=""#b0b0ff"">" & vbcrlf & _
		"			<xsl:value-of select=""limittxt"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>  " & vbcrlf & _
		"		<xsl:when test=""limit='16'"">" & vbcrlf & _
		"			<td bgcolor=""#ff8080"">" & vbcrlf & _
		"			<xsl:value-of select=""limittxt"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>  " & vbcrlf & _
		"		<xsl:when test=""limit='NewUser'"">" & vbcrlf & _
		"			<td bgcolor=""#80ff80"">" & vbcrlf & _
		"			<xsl:value-of select=""limittxt"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>  " & vbcrlf & _
		"		<xsl:otherwise>" & vbcrlf & _
		"			<td bgcolor=""#ffffff"">" & vbcrlf & _
		"			<xsl:value-of select=""limittxt"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:otherwise>" & vbcrlf & _
		"	</xsl:choose>" & vbcrlf & _
		"	<xsl:choose>" & vbcrlf & _
		"		<xsl:when test=""config='AD'"">" & vbcrlf & _
		"			<td bgcolor=""#ffff00"">" & vbcrlf & _
		"			<xsl:value-of select=""config"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>  " & vbcrlf & _
		"		<xsl:when test=""config='MBStore'"">" & vbcrlf & _
		"			<td bgcolor=""#b0b0ff"">" & vbcrlf & _
		"			<xsl:value-of select=""config"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>  " & vbcrlf & _
		"		<xsl:when test=""config='Policy?'"">" & vbcrlf & _
		"			<td bgcolor=""#80ff80"">" & vbcrlf & _
		"			<xsl:value-of select=""config"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>  " & vbcrlf & _
		"		<xsl:otherwise>" & vbcrlf & _
		"			<td bgcolor=""#FF8080"">" & vbcrlf & _
		"			<xsl:value-of select=""config"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:otherwise>" & vbcrlf & _
		"	</xsl:choose>" & vbcrlf & _
		"	<td>" & vbcrlf & _
		"		<xsl:value-of select=""limit1"" /><br/><xsl:value-of select=""limit2"" /><br/><xsl:value-of select=""limit3"" /> " & vbcrlf & _
		"	</td>" & vbcrlf & _
		"	<td>" & vbcrlf & _
		"		<xsl:value-of select=""limit1p"" /><br/><xsl:value-of select=""limit2p"" /><br/><xsl:value-of select=""limit3p"" /> " & 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 XMLTextWriter
'~ 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,value)  ' erg&auml;nzt eine ID zum aktuellen Element
		if isnull(value) then value = ""
		xmlobject.setAttribute name, value
	end sub
	

	sub WriteElementString(item,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

	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

Sub abbruch(info,waittime)
	' usage: call abbruch ("Script abbrechen" ,5)
	dim WshShell, result
	Set WshShell = CreateObject("WScript.Shell")
	result = WshShell.Popup("Continue script at position "& vbcrlf & info & vbcrlf & "Waiting "&waittime&" Seconds", waittime, "Stop Script", 33) 'OKCancel(1) + Question (32)
	If result = 2 Then
        WScript.echo "Abbruch durch Anwender (Exitcode = 255)"
        WScript.Quit(255)
    End If	
End Sub


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