'***********************************************************************************************
' $ScriptName: "ADC Process Check" $
'
' Purpose: Checks the ADC work to do using USN Changed attributes
'
' Parameters passed to the Script:
' int MaxDelta:  maximum USN Delta to generate an Event/Alert
' int debug:     Debugging. 0 = Output, 1 = output+error, 2 = output+error+waring 
' str Target	Specify DN to sinlge ADC to Check. if omissed, all ADC-CAs are checked
'
' Events created by this script:
' SOURCE	ID 	 	TYPE		DESCRIPTION
' CheckADC	 40 	error		MaxDelta exceeded ! 
' CheckADC	 100	information	MaxDelta not reached
' CheckADC	9000	error		Unable to read Exchange Organization, Check AD-permissions.
'
' $File: checkADCmom.vbs $
'
' $Date: 2005/07/13 18:16:06 $   $Revision: 1 $
' $Creator: fra---nk@carius.de
' Version 1.4  DN sonderbehandlung
'***********************************************************************************************
Option Explicit

Const EVENT_TYPE_SUCCESS = 0
Const EVENT_TYPE_ERROR   = 1
Const EVENT_TYPE_WARNING = 2
Const EVENT_TYPE_INFORMATION = 4
'Event ID Constants
Const EVENT_ID_BASE_STATE_OK = 100000
Const EVENT_SOURCE = "CheckADC"
const XMLOUTFILE = "C:\temp\fcarius\Checkadc4.xml"

Dim objRootDSE
Dim strConfigurationNC
Dim oCommand
Dim oConnection
Dim oRecordSet
Dim strExchangeOrg
Dim strADCContainer
Dim strQuery
Dim count
dim intDebug
dim lngMaxDelta 
dim strTarget
dim blnIsMOM

on error resume next  ' Disable Error handling temporarily
wscript.echo "Starting..."  ' Raises an error, if not running with WSH.
if err = 0 then 
	WSCript.ECHO "Running in MOM Emulation - Mode" 
	blnIsMOM = false
	intMaxDelta  = wscript.Arguments.named("MaxDelta")
	if intMaxDelta = "" then  intMaxDelta = 1000  ' using 1000 as default
	intdebug  = wscript.Arguments.named("Debug")
	if intdebug = "" then intdebug = 1 		 ' Output, Errors only
	strTarget = wscript.Arguments.named("Target")
else
	blnIsMOM = true
	intMaxDelta = ScriptContext.Parameters.Get("MaxDelta")
	intdebug = ScriptContext.Parameters.Get("Debug")
	strTarget = ScriptContext.Parameters.Get("Target")
end if
err.clear
on error goto 0   ' Enable Error handling again

debuglog "Script running", 0
debuglog "Parameter:MaxDelta =" & lngMaxDelta,0
debuglog "Parameter:Debugging=" & intdebug,0

dim xmlWriter
set xmlWriter = new XmlTextWriter
xmlWriter.filename = XMLOUTFILE
xmlWriter.Indentation = 4
call xmlWriter.WriteStylesheet("checkadc.xsl")
xmlWriter.WriteStartElement("CHECKADCMOM")

call xmlWriter.WriteElementString("StartTime", now())

if strTarget = "" then
	debuglog  "Search and connect to RootDSE" & strADCContainer, 4
	Set objRootDSE = GetObject("LDAP://RootDSE")
	strConfigurationNC = objRootDSE.Get("configurationNamingContext")
	strADCContainer = "CN=Active Directory Connections,CN=Microsoft Exchange,CN=Services," & strConfigurationNC
	debuglog  "DONE:ADCContainer=" & strADCContainer, 6
	
	debuglog  "Get all ADC-Entries 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://" & strADCContainer & ">;(objectCategory=msExchConnectionAgreement);name,distinguishedName;subtree"
	debuglog  "LDAP-String" & strQuery, 6
	oCommand.ActiveConnection = oConnection
	oCommand.CommandText = strQuery
	Set oRecordSet = oCommand.Execute
	debuglog  "DONE: Query returned " & oRecordSet.recordCount & " Objects", 4
	
	count = 0
	While (Not oRecordSet.EOF)  ' Process all ADC-Entries
		debuglog "CheckADC: "& count & "/" & oRecordSet.recordCount & " :" & oRecordSet.Fields("name"),3
		count = count +1
		Call CheckADC(replace(oRecordSet.Fields("distinguishedName"),"/","\/"))
		oRecordSet.MoveNext
		' if count = 4 then oRecordSet.movelast  ' if enabled, do a shorter Test
	Wend
	debuglog  "DONE: Total Items" & Count, 4
	
	debuglog  "CleanUp", 4
	oRecordSet.Close
	oConnection.Close
	Set oRecordSet = Nothing
	Set oCommand = Nothing
	Set oConnection = Nothing
else
	Call CheckADC(strTarget)
end if
call xmlWriter.WriteElementString("EndTime", now())
call xmlWriter.WriteEndElement()
if not blnIsMOM then call xmlWriter.close()
debuglog  "Script finished", 0



Sub CheckADC(strADCDN)
	Dim objADC
	
	debuglog  " Pr?e ADC:" & strADCDN,6
	Set objADC = GetObject("LDAP://" & strADCDN)
	' We do NOT check the replication schedule !! ("activationStyle"  2=Always, 0 =Never) see KB867627 
	' We do NOT filter on the CA-Type. May be possible using "msExchServer2SearchFilter" = "(|(objectclass=public-Folder))"
	' Field: msExchADCObjectType   1 = ConfigCA  0 = Recipient/Group/PF-CA
	'
	' Check Replication Active Directory to Exchange.  (msExchangeSynchronizationDirection)
		' 0 = TwoWay    1 = only from AD to Exychange    2 = From Exchange to AD

	if (objADC.get("msExchSynchronizationDirection") = 0) or (objADC.get("msExchSynchronizationDirection")=1) then
		' Two Way or AD to Exchange. So lets check AD:highestCommittedUSN > ADC:msExchServer1HighestUSN 
		debuglog  " ---- Checking AD to Exchange 5.5",3
		call CheckADCDirection(objADC,"msExchServer1")
	end if

	if (objADC.get("msExchSynchronizationDirection") = 0) or (objADC.get("msExchSynchronizationDirection")=2) then
		' Two Way or Exchange to AD. So lets check  EX5:highestCommittedUSN > ADC:msExchServer2HighestUSN
		debuglog  " ---- Checking Exchange 5.5 to AD",3
		call CheckADCDirection(objADC,"msExchServer2")
	end if
End Sub


sub CheckADCDirection(objca,strdirection)
	dim objtarget, dblHighestUSN, lngmissedobjects, strLDAPTarget, strou, varExportContainers
	' objCA = CA
	' strdirection = msExchServer1 or msExchServer1
	debuglog  " name         :" & objca.Name,4
	call xmlWriter.WriteStartElement("ADC-CA")
	call xmlWriter.WriteElementString("name", objca.Name)
	debuglog  " lastmodified :" & objca.whenchanged,4
	call xmlWriter.WriteElementString("lastmodified ", objca.whenchanged)
	debuglog  " Direction    :" & strDirection,4
	if strdirection = "msExchServer1" then 
		call xmlWriter.WriteElementString("Direction", "AD->55")
		call xmlWriter.WriteElementString("Server", objca.get("msExchServer2NetworkAddress")&":" & objCA.get("msExchServer2Port"))
	end if
	if strdirection = "msExchServer2" then 
		call xmlWriter.WriteElementString("Direction", "55->AD")
		call xmlWriter.WriteElementString("Server", objca.get("msExchServer1NetworkAddress")&":" & objCA.get("msExchServer1Port"))
	end if 
	select case objca.get("Activationstyle")
		case 0 	call xmlWriter.WriteElementString("Activation", "disabled")
		case 1 	call xmlWriter.WriteElementString("Activation", "selected")
		case 2	call xmlWriter.WriteElementString("Activation", "always")
		case else 	call xmlWriter.WriteElementString("Activation", "unknown=" & objca.get("Activationstyle"))
	end select
	dblHighestUSN = Abs(objca.get(strdirection & "HighestUSN").HighPart * 2^32 + objca.get(strdirection & "HighestUSN").LowPart)
	debuglog  " ADCHighestUSN:" & dblHighestUSN,4
	call xmlWriter.WriteElementString("ADCHighestUSN", dblHighestUSN)
	strLDAPTarget = "LDAP://" & objca.get(strdirection&"NetworkAddress")&":" & objCA.get(strdirection&"Port")
	debuglog  " TargetLDAP:" & strLDAPTarget,4
	on error resume next
	Set objtarget = GetObject(strLDAPTarget & "/RootDSE")
	if err = 0 then
		on error goto 0
		debuglog  " TargetHighUSN:" & objtarget.get("highestCommittedUsn"),4
		call xmlWriter.WriteElementString("TargetHighUSN", objtarget.get("highestCommittedUsn"))
	
		lngmissedobjects =   objtarget.get ("highestCommittedUsn")-dblHighestUSN
		debuglog  " USNDiff      :" & lngmissedobjects,4
		call xmlWriter.WriteElementString("USNDiff", lngmissedobjects)
	
		call xmlWriter.WriteStartElement("Objects")
		varExportContainers = objca.get(strdirection & "ExportContainers")
		lngmissedobjects = 0
		if Vartype(objca.get (strdirection & "ExportContainers")) >8192 then
			for each strou in objca.get (strdirection & "ExportContainers")
				debuglog  " counting  OUx :" & strou ,4
				lngmissedobjects = lngmissedobjects + listuntouchedobjects(dblHighestUSN, objtarget.get("highestCommittedUsn"),strLDAPTarget & "/" & strou)
			next
		else
			debuglog  " counting OU1 :" & objca.get (strdirection & "ExportContainers"),4
			lngmissedobjects = listuntouchedobjects(dblHighestUSN, objtarget.get("highestCommittedUsn"),strLDAPTarget & "/" & objca.get (strdirection & "ExportContainers"))
		end if 
		call xmlWriter.WriteEndElement()
		debuglog  " MissedObjects: " & lngmissedobjects ,4
		call xmlWriter.WriteElementString("MissedObjects", lngmissedobjects)
	else
		err.clear
		on error goto 0
		debuglog  " ServerFail:" & objca.get(strdirection&"NetworkAddress"),2
		call xmlWriter.WriteElementString("TargetHighUSN", "-1")
		call xmlWriter.WriteElementString("USNDiff", "-1")
		call xmlWriter.WriteElementString("MissedObjects", "-1")
		Createalert "ERROR", objca.Name & " Server unreachable:" & objca.get(strdirection&"NetworkAddress"),EVENT_SOURCE,50
	end if 
	
	if clng(lngmissedobjects) > clng(lngMaxDelta) then
		Createalert "ADC USN", objca.Name & " MaxDelta exceeded ! Missing:" & lngmissedobjects &" Objects",EVENT_SOURCE,50
	else	
		CreateEvent 100,EVENT_TYPE_INFORMATION,EVENT_SOURCE,objca.Name & " MaxDelta not reached. Pending Objects: "&lngmissedobjects
	end if
	call xmlWriter.WriteEndElement()  ' of ADCCA
end sub

function listuntouchedobjects(lowusn, highusn, ldappath)
	Dim oConnection, oCommand, oRecordSet,ousn, dblusn, oobj, count
	
	Set oConnection = CreateObject("ADODB.Connection")
	Set oCommand = CreateObject("ADODB.Command")
	Set oRecordSet = CreateObject("ADODB.RecordSet")
	
	' Open the Connection
	oConnection.Provider = "ADsDSOObject"
	oConnection.Open "ADs Provider"
	
	' Build query to find all pending ADC-Entries
	debuglog  "ListObject:LDAP-Path"&ldappath,4
	strQuery = "<" & ldappath & ">;(&(USNChanged>="&lowusn&")(USNChanged<=" & highusn &")(objectclass=*));"& _
							"name,distinguishedName;subtree"
	'~ strQuery = "<" & ldappath & ">;(&(USNChanged>="&lowusn&")(USNChanged<=" & highusn &")(objectclass=*));"& _
							'~ "name,distinguishedName,whenchanged,usnchanged;subtree"
	debuglog  "ListObject:LDAP-String List"&strQuery,4
	oCommand.ActiveConnection = oConnection
	oCommand.CommandText = strQuery
	oCommand.Properties("Sort On")= "USNChanged"
	oCommand.Properties("Page Size")= 100   'PagedRead aktivieren
	on error resume next
	Set oRecordSet = oCommand.Execute
	if err = 0 then
		on error goto 0
		debuglog  "ListObject:Records count:" & oRecordSet.recordCount,4
		count = 0
		While (Not oRecordSet.EOF)
			count = count + 1
			'~ dblusn = oRecordSet.Fields("usnchanged")
			'~ Set ousn = dblusn  ' Kleiner Umweg um den VBVariant mit Lowpart/Highpart nutzen zu k?nen
			'~ dblusn = Abs(ousn.HighPart * 2^32 + ousn.LowPart)
			'~ debuglog  "ListObject:Pending: USN=" & dblusn & "," & oRecordSet.Fields("whenchanged") & "," & oRecordSet.Fields("name"),6
			debuglog  "ListObject:Pending: " & count & "/" & oRecordSet.recordCount &":"& oRecordSet.Fields("name"),5
			call xmlWriter.WriteElementString("Missing", oRecordSet.Fields("name"))
	
			oRecordSet.MoveNext
		Wend
	else
		debuglog  "ListObject:Error beim Datenbankzugriff:" & ldappath,1
		err.clear
		count = 0  ' Objekte werden ignoriert. BEsser w?e eine Abhandlung aber noch nicht implementiert.
		on error goto 0
	end if 
	debuglog  "ListObject:Cleanup",4	
	oRecordSet.Close     'Clean up
	oConnection.Close
	Set oRecordSet = Nothing
	Set oCommand = Nothing
	Set oConnection = Nothing
	listuntouchedobjects = count
End function


Sub CreatePerfData(strObjectName,strCounterName,strInstanceName,numValue)
	'	ObjectName Name of the performance object
	'	CounterName Name of the performance counter
	'	InstanceName Name of the performance instance
	' 	Value Numeric value of the data
	'Sample:  CreatePerfData "File","File Size",objFile.Path,objFile.Size
	' CreatePerfData <ObjectName>,<CounterName>,<InstanceName>,<Value>

	if blnismom then 
		Set objPerfData = ScriptContext.CreatePerfData
		objPerfData.ObjectName = strObjectName
		objPerfData.CounterName =strCounterName
		objPerfData.InstanceName = strInstanceName
		objPerfData.Value = numValue
		ScriptContext.Submit objPerfData
	else
		wscript.echo "-------------- ALERT --------------------"
		wscript.echo "Perfname    :"& strObjectName
		wscript.echo "PerfCounter :"& strCounterName
		wscript.echo "PerfInstance:"& strInstanceName
		wscript.echo "PerfValue:"& numValue
	end if 
End Sub

Sub CreateEvent(intEventNumber,intEventType,strEventSource,strEventMessage)
' 	CreateEvent <EventNumber>,<EventType>,<EventSource>,<Message>
'	CreateEvent 100,EVENT_TYPE_INFORMATION,"Script Test","Hello world."
	if blnismom then 
		dim objEvent 
		Set objEvent = ScriptContext.CreateEvent()
		objEvent.EventNumber = intEventNumber
		objEvent.EventType = intEventType 
		objEvent.EventSource = strEventSource
		objEvent.Message = strEventMessage
		ScriptContext.Submit objEvent
		Set objEvent = Nothing
	else
		wscript.echo "-------------- EVENT --------------------"
		wscript.echo "EventNumber:"& intEventNumber
		wscript.echo "EventType  :"& intEventType 
		wscript.echo "EventSource:"& strEventSource
		wscript.echo "Message    :"& strEventMessage
	end if
End Sub

Sub CreateAlert(ByVal sName, ByVal sDescription, ByVal sSource, ByVal lAlertLevel)
'	CreateAlert "Name","Description","Source",9000

	if blnismom then 
		Dim oAlert
		Set oAlert = ScriptContext.CreateAlert()
		oAlert.Name = sName  ' Name der Regel, die den Alert startet
		oAlert.Description = sDescription
		oAlert.AlertSource = sSource
		oAlert.AlertLevel = lAlertLevel  ' Severity   
		'							10 Success 
		'							20 Information 
		'							30 Warning 
		'							40 Error 
		'							50 Critical Error 
		'							60 Security Issue 
		'							70 Service unavailable 
		' oAlert.Owener = "[unassigned]"
		' oAlert.ResolutionState = 0  ' New
		ScriptContext.Submit oAlert
	else
		wscript.echo "-------------- ALERT --------------------"
		wscript.echo "Alertname  :"& sName  
		wscript.echo "AlertLevel :"& lAlertLevel
		wscript.echo "AlertSource:"& sSource
		wscript.echo "Description:"& sDescription
	end if 
End Sub

sub debuglog (byval strMessage, byval intlevel)
	' Please use th following levels
	' =0 normal Output data / processing Data
	' =1 Errors
	' =2 Warnings
	' =3 Informational messages
	' >3 Debug Messages
	if cint(intlevel) <= cint(intdebug) then 
		if blnismom then 
			scriptContext.echo now() &","& intlevel &":"& strMessage
		else 
			wscript.echo now() &","& intlevel &":"& strMessage
		end if 
	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
		' Converts non printable characters to "X" , so that Textfile is working
		dim loopcount, tempwert, inttest
		tempwert=""
		if isnull(wert) then
			quote = ""
		else
			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
			if len (tempwert ) > 0 then
				tempwert=replace(tempwert ,"&","&amp;")
				tempwert=replace(tempwert ,"<","&lt;")
				tempwert=replace(tempwert ,">","&gt;")
				tempwert=replace(tempwert ,"""","&quot;")
				tempwert=replace(tempwert ,"'","&apos;")
			end if
			quote=tempwert 
		end if
	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