Option Explicit
'-------------------------------------------------------------------------
' AltRecipients
'
' Beschreibung
' Suche im GC alle Exchange Empfänger und gibt den "Alternate Recipient" aus.
'
' (c)2006 Net at Work Netzwerksysteme GmbH
'
' Version 1.0 (15. Jun 2007) Frank Carius
'	Erste Version
' Version 1.1 (14. Aug 2007) Frank Carius
'	Domain muss als Parameter angegeben werden
'

Dim result, xmlWriter
Dim oConnection, oCommand, oRecordset
Dim strTemp, strQuery, lngpage, strObjectClass, strOutFilePrefix
Dim counter, strOrgmode, objOrgmode 
Dim totalobjects, count
Dim objAltRecipient, strAltRecipientDN
Dim test

strOutFilePrefix = makefilename("AltRecipient-" & Date() & "-" & Time())
' Pfad und Dateiname der Log-Datei
Dim objDebug
Set objDebug = New DebugWriter 
objDebug.target = "file:6 console:6" ' 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
'~ call abbruch ("Script fortsetzen ?" ,5)  ' Last question to stop
objDebug.writeln "AltRecipient: gestartet", 0

if WScript.Arguments.Count = 0 then
	objDebug.writeln "Bitte aufrufen mit gültigem AD-Pfad", 3
	objDebug.writeln "z.B.", 3
	objDebug.writeln "cscript altrecipient.vbs ""GC://firma.intern""", 3
	objDebug.writeln "cscript altrecipient.vbs ""LDAP://firma.intern""", 3
	objDebug.writeln "cscript altrecipient.vbs ""LDAP://server/firma.intern""", 3
else 
	dim strADLdap 
	strADLdap = wscript.arguments(0)
	objDebug.writeln "Processing:" & strADLdap, 0

	Set xmlWriter = New XmlTextWriter
	Call writexslt("AltRecipient.xsl")   ' Stylesheet schreiben
	xmlWriter.filename = strOutFilePrefix & ".xml"
	xmlWriter.Indentation = 4
	Call xmlWriter.WriteStylesheet("AltRecipient.xsl")
	Call xmlWriter.WriteStartElement("AltRecipient")
	Call xmlWriter.WriteElementString("starttime1", Now())

	totalobjects = 0

	objDebug.writeln " Start ADODB Search:" & strADLdap, 5
	Set oConnection = CreateObject("ADODB.Connection")
	Set oRecordset = CreateObject("ADODB.Recordset")
	Set oCommand = CreateObject("ADODB.Command")
	oConnection.Provider = "ADsDSOObject"  'The ADSI OLE-DB provider
	oConnection.Open "ADs Provider"
	oCommand.ActiveConnection = oConnection
	oCommand.Properties("Page Size") = 100
	oCommand.CommandText = "<" & strADLdap & ">;" & _
		"(&(mailnickname=*)(AltRecipient=*));" & _
		"distinguishedName,ObjectClass,displayName,mail,AltRecipient" & _
		";subtree"
	Set oRecordset = oCommand.Execute
	objDebug.writeln "Done Total Records found:" & oRecordset.recordcount, 0
	Call xmlWriter.WriteElementString("starttime2", Now())

	objDebug.writeln "-----------------------------------------------------------------------",0
	objDebug.writeln "Process Recipients",0

	Do until oRecordset.EOF
		totalobjects = totalobjects + 1
		Call xmlWriter.WriteStartElement("object")

		objDebug.writeln "----- Object:" & totalobjects  & "/" & oRecordset.recordcount &":" & Left(oRecordset.Fields("distinguishedName"),30),3
		Call xmlWriter.WriteElementString("distinguishedName", oRecordset.Fields("distinguishedName"))
		Call xmlWriter.WriteElementString("displayName", oRecordset.Fields("displayName"))
		Call xmlWriter.WriteElementString("mail", oRecordset.Fields("mail"))
		
		strAltRecipientDN = oRecordset.Fields("AltRecipient").value
		If IsNull(strAltRecipientDN) Then
			objDebug.writeln "    No Alternate Recipient",3
			Call xmlWriter.WriteElementString("AltRecipient","NONE")
			Call xmlWriter.WriteElementString("AltRecipientMail","NONE")
			Call xmlWriter.WriteElementString("status","OK")
		Else
			objDebug.writeln "   Alternate Recipient DN:" & strAltRecipientDN,3
			Call xmlWriter.WriteElementString("AltRecipient",strAltRecipientDN)
			
			On Error Resume Next
			Set objAltRecipient = GetObject("LDAP://" & strAltRecipientDN)
			If Err.number = 0 Then
				objDebug.writeln "   Alternate Recipient Bound:" & objAltRecipient.distinguishedname,3
				Call xmlWriter.WriteElementString("AltRecipientMail",objAltRecipient.mail)
				If Err.number = 0 Then
					On Error Goto 0
					objDebug.writeln "   Alternate Recipient Mail:" & objAltRecipient.mail,3
					Call xmlWriter.WriteElementString("status","OK")
				Else 
					Err.clear : On Error Goto 0 
					objDebug.writeln "   Alternate Recipient Mail: ERROR Getting Mail:"&strAltRecipientDN,1
					Call xmlWriter.WriteElementString("status","Err:GetMail")
				End If 
			Else
				Err.clear : On Error Goto 0 
				objDebug.writeln "   Alternate Recipient Mail: ERROR Binding:"&strAltRecipientDN,1
				Call xmlWriter.WriteElementString("status","Err:LDAPBind")		
			End If
		End If
		Call xmlWriter.WriteEndElement   ' of ("object")
		oRecordset.MoveNext
	Loop

	Call xmlWriter.WriteElementString("endtime", Now())
	Call xmlWriter.WriteElementString("totalobjects", totalobjects)
	Call xmlWriter.WriteEndElement()   ' of ("AltRecipient")
	objDebug.writeln "Schreibe XML-Datei: " & xmlWriter.filename ,3
	Call xmlWriter.Close               ' XML schreiben
end if
objDebug.writeln "Ende: " ,3
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>AltRecipient Status</title></head>" & VbCrLf & _
		"<body>" & VbCrLf & _
		"<h1>AltRecipient Status</h1> " & VbCrLf & _
		"<h2>Summary</h2> " & VbCrLf & _
		"<xsl:for-each select=""AltRecipient""> " & VbCrLf & _
		"<table border=""1"" width=""100%"">" & VbCrLf & _
		"	<tr><th>Start Verarbeitung</th> <td><xsl:value-of select=""starttime1"" /></td></tr>" & VbCrLf & _
		"	<tr><th>Start Process Objects</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>#Total Recipients checked</th> <td><xsl:value-of select=""totalobjects"" /></td></tr>" & VbCrLf & _
		"</table>" & VbCrLf & _
		"</xsl:for-each>" & VbCrLf & _
		"<h2>Objects</h2> " & VbCrLf & _
		"<table border=""1"" width=""100%"">" & VbCrLf & _
		"  <tr bgcolor=""#808080"">" & VbCrLf & _
		"	<th>DisplayName:</th> " & VbCrLf & _
		"	<th>Mail:</th> " & VbCrLf & _
		"	<th>AltRecipientMail:</th> " & VbCrLf & _
		"	<th>Status:</th> " & VbCrLf & _
		"  </tr>" & VbCrLf & _
		"<xsl:for-each select=""AltRecipient/object""> " & VbCrLf & _
		"	<tr>" & VbCrLf & _
		"	<td>" & VbCrLf & _
		"		<xsl:value-of select=""displayName"" /> " & VbCrLf & _
		"	</td>" & VbCrLf & _
		"	<td>" & VbCrLf & _
		"		<xsl:value-of select=""mail"" /> " & VbCrLf & _
		"	</td>" & VbCrLf & _
		"	<td>" & VbCrLf & _
		"		<xsl:value-of select=""AltRecipientMail"" /> " & VbCrLf & _
		"	</td>" & VbCrLf & _
		"	<xsl:choose>" & VbCrLf & _
		"		<xsl:when test=""status='OK'"">" & VbCrLf & _
		"			<td bgcolor=""#80ff80"">" & VbCrLf & _
		"			<xsl:value-of select=""status"" /> " & VbCrLf & _
		"			</td>" & VbCrLf & _
		"		</xsl:when>  " & VbCrLf & _
		"		<xsl:when test=""status='Err:*'"">" & VbCrLf & _
		"			<td bgcolor=""#80ffff"">" & VbCrLf & _
		"			<xsl:value-of select=""status"" /> " & VbCrLf & _
		"			</td>" & VbCrLf & _
		"		</xsl:when>  " & VbCrLf & _
		"		<xsl:otherwise>" & VbCrLf & _
		"			<td bgcolor=""#ff8080"">" & VbCrLf & _
		"			<xsl:value-of select=""status"" /> " & VbCrLf & _
		"			</td>" & VbCrLf & _
		"		</xsl:otherwise>" & VbCrLf & _
		"	</xsl:choose>" & 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