Option Explicit

'-------------------------------------------------------------------------
' checktrackingv1.0.vbs
'
' Beschreibung
' Gibt f? alle Server der Org den Status des Nachrichtentracking und die Exchange Version aus
' 
' Laufzeitfehler werde nicht abgefangen und beenden das Skript.
'
' Das Skript wird mit den Berechtigungen des angemeldeten Benutzers
' ausgef?rt. Die entsprechenden Berechtigungen sind sicher zu stellen
'
' (c)2005 Frank Carius
' 
' Version 1.0 (12. Juli 2005)
' Version 1.1 (24 Juli 2005)  Umstellung  auf XML
'-------------------------------------------------------------------------
' Pfad und Dateiname der Log-Datei
Const ForAppending = 8
Const ForWriting = 2
Const ForReading = 1
Const LogFile = "C:\checktracking.log"
' errorlogging  0=no logging, 1=Fatal  2=Error 3=Warning 4=information  5=debug
Const LogLevel = 5      ' Ausgabe in Datei
Const screenlevel  = 4  ' Ausgabe auf Bildschirm 

Const XMLOUTFILE = "checktracking.xml"
Const XSLOUTFILE = "checktracking.xsl"

Dim objRootDSE                  ' 
Dim strConfigurationNC          ' 
Dim oCommand               ' 
Dim oConnection            ' 
Dim oRecordSet             ' 
Dim strPOLContainer        ' 
Dim strQuery
dim strExchangeOrg 
Dim count

WScript.Echo WScript.ScriptName & " wurde gestartet."
AppendLog "Skript "& WScript.ScriptName &" gestartet", 4

AppendLog "Searching für RootDSE", 4
Set objRootDSE = GetObject("LDAP://RootDSE")
strConfigurationNC = objRootDSE.Get("configurationNamingContext")

AppendLog "ConfigNC=" & strConfigurationNC, 4

AppendLog "Searching für Exchange Org using ADODB", 4
Set oConnection = CreateObject("ADODB.Connection")
Set oCommand = CreateObject("ADODB.Command")
Set oRecordSet = CreateObject("ADODB.RecordSet")
oConnection.Provider = "ADsDSOObject"
oConnection.Open "ADs Provider"
strQuery = "<LDAP://CN=Microsoft Exchange,CN=Services," & strConfigurationNC & ">;(objectclass=msExchOrganizationContainer);"& "name,distinguishedName"
AppendLog  "LDAP-String"&strQuery,4
oCommand.ActiveConnection = oConnection
oCommand.CommandText = strQuery
Set oRecordSet = oCommand.Execute
AppendLog "DONE: Query returns", 4

if oRecordSet.EOF then
	AppendLog  "Unable to read Exchange Organization, Check AD-permissions.", 1
	CreateAlert "OrgRead", "Unable to read Exchange Organization, Check AD-permissions.",EVENT_SOURCE,50
	ScriptContext.quit(1)
else
	AppendLog  "FOUND:Orgname=" & oRecordSet.Fields("name"), 0
	AppendLog  "OrgDN=" & oRecordSet.Fields("distinguishedName"), 4
	strExchangeOrg = oRecordSet.Fields("name")
end if

strPOLContainer = "CN=" & strExchangeOrg & ",CN=Microsoft Exchange,CN=Services," & strConfigurationNC
Set oConnection = CreateObject("ADODB.Connection")
Set oCommand = CreateObject("ADODB.Command")
Set oRecordSet = CreateObject("ADODB.RecordSet")
oConnection.Provider = "ADsDSOObject"				' Open the Connection
oConnection.Open "ADs Provider"
' Build the query to find all Servers
strQuery = "<LDAP://" & strPOLContainer & ">;(&(objectClass=msExchExchangeServer)(!objectClass=msExchExchangeServerPolicy));"& _
						"name,distinguishedName,messageTrackingEnabled,msExchTrkLogCleaningInterval,versionNumber;subtree"  ',
AppendLog "LDAP-String:"&strQuery,4
oCommand.ActiveConnection = oConnection
oCommand.CommandText = strQuery
Set oRecordSet = oCommand.Execute

count = 0


dim xmlWriter
set xmlWriter = new XmlTextWriter
xmlWriter.filename = XMLOUTFILE
xmlWriter.Indentation = 4
call xmlWriter.WriteStylesheet(XSLOUTFILE)
call xmlWriter.WriteStartElement("CHECKTRACKING")
call xmlWriter.WriteElementString("STARTTIME", now())

While (Not oRecordSet.EOF)
	count = count +1
	AppendLog "Server         : "& oRecordSet.Fields("name"),0
	AppendLog "Tracking       : "& oRecordSet.Fields("messageTrackingEnabled"),0
	AppendLog "Haltezeit      : "& oRecordSet.Fields("msExchTrkLogCleaningInterval"),0
	AppendLog "ExchangeVersion: "& oRecordSet.Fields("versionNumber"),0
	call xmlWriter.WriteStartElement("SERVER")
	call xmlwriter.WriteAttributeString("NAME",oRecordSet.Fields("name"))
	call xmlWriter.WriteElementString("NAME",oRecordSet.Fields("name"))
	if  oRecordSet.Fields("messageTrackingEnabled") = true then
		call xmlWriter.WriteElementString("TRACKING" ,"1")
	else
		call xmlWriter.WriteElementString("TRACKING" ,"0")
	end if
	call xmlWriter.WriteElementString("HALTEZEIT",oRecordSet.Fields("msExchTrkLogCleaningInterval"))
	call xmlWriter.WriteElementString("EXCHANGEVERSION",oRecordSet.Fields("versionNumber"))
	call xmlWriter.WriteEndElement()
	oRecordSet.MoveNext
Wend
call xmlWriter.WriteElementString("ENDTIME", now())
call xmlWriter.WriteElementString("TOTAL", count)
call xmlWriter.WriteEndElement()
AppendLog "-------------Server Total:"&count ,0
call xmlwriter.close

oRecordSet.Close     'Clean up
oConnection.Close
Set oRecordSet = Nothing
Set oCommand = Nothing
Set oConnection = Nothing
AppendLog "Skript beendet", 0
WScript.quit(0)


Sub AppendLog(strLog, errlevel)
'F?t einen Eintrag in die Log-Datei ein
	Dim file
	Dim fs

	If LogLevel>=errlevel Then
		Set fs = CreateObject("Scripting.FileSystemObject")
		Set file = fs.OpenTextFile(LogFile, 8, True)
		file.Write(Now & ",")
		Select Case errlevel
			Case 0	file.Write("Out")
			Case 1	file.Write("Fatal Line" & Err.Source)
			Case 2	file.Write("Error")
			Case 3	file.Write("Warning")
			Case 4	file.Write("Information")
			Case 5	file.Write("Debug")
			Case Else file.Write("Code:"&errlevel)
		End Select
		file.WriteLine(","&strLog)
		file.Close
	End If
	If screenlevel>=errlevel Then
		Select Case errlevel
			Case 0	WScript.echo ("Out:"&strLog)
			Case 1	WScript.echo (Now & "Fatal:" & Err.Source)
			Case 2	WScript.echo (Now & "Error:"&strLog)
			Case 3	WScript.echo (Now & "Warn :"&strLog)
			Case 4	WScript.echo (Now & "Info :"&strLog)
			Case 5	WScript.echo (Now & "Debug:"&strLog)
			Case Else WScript.echo (Now & "Code:"&errlevel)
		End Select
	End If	
End Sub



' Generic Class to make creation of XML-Files a litte bit easier
' similar to the .NET XMLWriter Class

class XMLTextWriter
	dim txtXML
	dim intIndentation
	dim level
	dim strFilename
	dim Stack(100)  ' i have problems using redim, so i use a fixed number für the depth

	private Sub Class_Initialize
		intIndentation = 4
		level  = 0
		' txtxml = "<?xml version='1.0' encoding='utf-8'?>" & vbcrlf 
		txtxml = "<?xml version='1.0' encoding='ISO-8859-1'?>" & vbcrlf 
	End Sub
	
	public Property let filename(wert)
		strFilename = wert
	End Property
	public Property let Indentation(wert)
		intIndentation = wert
	End Property

	sub Writestylesheet (item)
		'* <?xml-stylesheet type="text/xsl" href="checkrus.xsl" ?>
		if instr(txtxml,"<?xml-stylesheet") = 0 then
			txtxml = "<?xml-stylesheet type=""text/xsl"" href="""& item &"""?>" & vbcrlf & txtxml
		else
		end if 
	end sub

	sub WriteStartElement(item)
		txtxml = txtxml & vbcrlf & space(intIndentation*level) & "<" & quote(trim(item)) & ">"
		stack(level) = item
		level = level + 1 
	end sub
	
	sub WriteAttributeString(item,wert)  ' erg?zt eine ID zum aktuellen Element
		txtxml = left(txtxml,len(txtxml)-1) & " id=""" & Quote(wert) & """>"
	end sub
	
	sub WriteElementString(item,wert)  ' <item>wert</item>
		txtxml = txtxml & vbcrlf & space(intIndentation*level) & "<" & quote(trim(item)) & ">" & quote(wert) & "</" & quote(item) & ">"
	end sub
	
	sub WriteEndElement()
		level = level - 1
		txtxml = txtxml & vbcrlf & space(intIndentation*level) & "</" & quote(stack(level))& ">"
	end sub


	function getXML()
		getXML = txtxml
	end function
	
	private function quote(wert)
		' 308060 HOW TO: Locate and Replace Special Characters in an XML File with Visual Basic .NET
		' quotes ?.
		wert=replace(wert,"&","&amp;")
		wert=replace(wert,"<","&lt;")
		wert=replace(wert,">","&gt;")
		wert=replace(wert,"""","&quot;")
		wert=replace(wert,"'","&apos;")
		quote=wert
	end function
	
	sub close()
		Const ForWriting = 2
		dim fs, file
		Set fs = CreateObject("Scripting.FileSystemObject")
		Set file = fs.OpenTextFile(strfilename, ForWriting, True)
		file.writeline txtxml
		file.Close
	end sub
end class