Option Explicit '------------------------------------------------------------------------- ' checkrus.vbs ' ' Beschreibung ' Prueft die Funktion des RUS und zeigt offene Objekte an ' ' Laufzeitfehler werde nicht abgefangen und beenden das Skript. ' ' Das Skript wird mit den Berechtigungen des angemeldeten Benutzers ' ausgeführt. Die entsprechenden Berechtigungen sind sicher zu stellen ' ' (c)2005 Net at Work Netzwerksysteme GmbH ' ' Version 1.0 (08 Juli 2005) ' Version 1.1 (11. Juli 2005) ' Fehlerbereinigung Domains, Ergänzung USNDiff, Ausgabe als Tabelle oder XML ' Version 1.2 ( 1. Jan 2006) ' Sonderfall mit \/ im DN abgefangen ' Version 1.3 ( 20.Oct 2006) ' Einbau des Exchange Org Objekts ' DebugWriter , XMLWriter ' Umfangreiche umformatierungen ' Erkennen von DE und EN Meldungen '------------------------------------------------------------------------- Dim objRootDSE, strConfigurationNC Dim oCommand, oConnection, oRecordSet Dim strRUSContainer, strQuery Dim count dim strOutFilePrefix strOutFilePrefix = makefilename("CheckRUS-" & Date() & "-" & Time()) ' common name of the output files without extension dim objDebug set objdebug = new DebugWriter objDebug.target = "file:5 console:3" 'ie:2 eventlog:2" ' errorlogging 0=only output, 1=Error 2=Warning 3=information 5++ =debug objDebug.outFile = strOutFilePrefix & ".log" objDebug.writeln "Skript gestartet", 0 dim xmlWriter set xmlWriter = new XmlTextWriter xmlWriter.filename = strOutFilePrefix & ".xml" xmlWriter.Indentation = 4 call xmlWriter.WriteStylesheet("CheckRUS.xsl") '~ call writexslt("CheckRUS.xsl") call xmlWriter.WriteStartElement("CheckRUS") call xmlWriter.WriteElementString("starttime", now()) WScript.Echo WScript.ScriptName & " wurde gestartet." objDebug.writeln "Skript "& WScript.ScriptName &" gestartet", 4 Set objRootDSE = GetObject("LDAP://RootDSE") strConfigurationNC = objRootDSE.Get("configurationNamingContext") 'strDomainName = objRootDSE.Get("DefaultNamingContext") objDebug.writeln "ConfigNC=" & strConfigurationNC, 4 strRUSContainer = "CN=Recipient Update Services,CN=Address Lists Container,CN=" &_ ExchangeOrg("name") & ",CN=Microsoft Exchange,CN=Services," & strConfigurationNC objDebug.writeln "RUSContainer=" & strRUSContainer,4 Set oConnection = CreateObject("ADODB.Connection") Set oCommand = CreateObject("ADODB.Command") Set oRecordSet = CreateObject("ADODB.RecordSet") oConnection.Provider = "ADsDSOObject" oConnection.Open "ADs Provider" ' Build the query to find all RUS-Entries strQuery = ";(objectCategory=msExchAddressListService);"& _ "name,distinguishedName;subtree" objDebug.writeln "LDAP-String"&strQuery,4 oCommand.ActiveConnection = oConnection oCommand.CommandText = strQuery Set oRecordSet = oCommand.Execute count = 0 While (Not oRecordSet.EOF) objDebug.writeln "ListRUS: "& oRecordSet.Fields("name"),4 count = count +1 Call CheckRus(oRecordSet.Fields("distinguishedName"),count) oRecordSet.MoveNext Wend oRecordSet.Close 'Clean up oConnection.Close Set oRecordSet = Nothing Set oCommand = Nothing Set oConnection = Nothing call xmlWriter.WriteElementString("endtime", now()) call xmlWriter.WriteEndElement ' of CheckRUS objDebug.writeln "Schreibe XML", 0 call xmlWriter.flush call xmlWriter.close objDebug.writeln "Skript beendet", 0 WScript.quit(0) Sub CheckRus(strRusDN,id) Dim objRUS, objtarget, dblHighestUSN objDebug.writeln "SUB:Checkrus ===============================",0 objDebug.writeln " Prüfe RUS:" & strRusDN,4 call xmlWriter.WriteStartElement("element") call xmlWriter.WriteElementString("RusDN", strRusDN) Set objRUS = GetObject("LDAP://" & replace(strRusDN,"/","\/")) objRUS.GetInfo ' Objekt aktuell einlesen call xmlWriter.WriteElementString("id", id) objDebug.writeln " name :" & objRUS.Name,0 objDebug.writeln " ID :" & id,5 call xmlWriter.WriteElementString("Name",objRUS.Name) objDebug.writeln " lastmodified :" & objRUS.whenchanged,3 call xmlWriter.WriteElementString("whenchanged", objRUS.whenchanged) dblHighestUSN = Abs(objRUS.get("msExchServer1HighestUSN").HighPart * 2^32 + objRUS.get("msExchServer1HighestUSN").LowPart) objDebug.writeln " RUSHighestUSN:" & dblHighestUSN,3 call xmlWriter.WriteElementString("msExchServer1HighestUSN", dblHighestUSN) objDebug.writeln " :" & objRUS.get("msExchServer1NetworkAddress"),4 call xmlWriter.WriteElementString("msExchServer1NetworkAddress", objRUS.get("msExchServer1NetworkAddress")) Set objtarget = GetObject("LDAP://" & objRUS.get("msExchServer1NetworkAddress") &"/"& "RootDSE") 'Zum Ziel Verbinden objDebug.writeln " ADHighUSN :" & objtarget.get ("highestCommittedUsn"),0 call xmlWriter.WriteElementString("highestCommittedUsn", objtarget.get ("highestCommittedUsn")) objDebug.writeln " USNDiff :" & objtarget.get ("highestCommittedUsn")-dblHighestUSN ,0 call xmlWriter.WriteElementString("USNDiff", objtarget.get ("highestCommittedUsn") - dblHighestUSN) ' ermittle und zeige fehlende Objekte Call listuntouchedobjects(dblHighestUSN, objtarget.get ("highestCommittedUsn"),objRUS.get("msExchDomainLink"),id) call xmlWriter.WriteEndElement End Sub Sub listuntouchedobjects(lowusn, highusn, ldapscope,id) 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 RUS-Entries strQuery = ";(&(USNChanged>="&lowusn&")(USNChanged<="&highusn&")(objectclass=*));"& _ "name,distinguishedName,mailnickname,whenchanged,usnchanged;subtree" objDebug.writeln "LDAP-String List"&strQuery,4 oCommand.ActiveConnection = oConnection oCommand.CommandText = strQuery oCommand.Properties("Sort On")= "USNChanged" Set oRecordSet = oCommand.Execute call xmlWriter.WriteStartElement("Pending") count = 0 While (Not oRecordSet.EOF) if isnull(oRecordSet.Fields("mailnickname")) then objDebug.writeln " NOT Pending: USN=" & dblusn &"," & oRecordSet.Fields("whenchanged") & "," & oRecordSet.Fields("name") & "," & oRecordSet.Fields("mailnickname"),5 else count = count + 1 dblusn = oRecordSet.Fields("usnchanged") Set ousn = dblusn ' Kleiner Umweg um den VBVariant mit Lowpart/Highpart nutzen zu können dblusn = Abs(ousn.HighPart * 2^32 + ousn.LowPart) objDebug.writeln " Pending: USN=" & dblusn &"," & oRecordSet.Fields("whenchanged") & "," & oRecordSet.Fields("name") & "," & oRecordSet.Fields("mailnickname"),3 call xmlWriter.WriteElementString("USN", dblusn) call xmlWriter.WriteElementString("whenchanged", oRecordSet.Fields("whenchanged")) call xmlWriter.WriteElementString("dn", oRecordSet.Fields("name")) call xmlWriter.WriteElementString("mailnickname", oRecordSet.Fields("mailnickname")) end if oRecordSet.MoveNext Wend call xmlWriter.WriteElementString("count", count) call xmlWriter.WriteEndElement ' of Pending oRecordSet.Close 'Clean up oConnection.Close Set oRecordSet = Nothing Set oCommand = Nothing Set oConnection = Nothing End Sub function ExchangeOrg(question) ' Question = name, dn, mixed dim objRootDSE, strConfigurationNC, oConnection, oCommand, oRecordSet, strQuery objDebug.write "Connecting to RootDSE" Set objRootDSE = GetObject("LDAP://RootDSE") strConfigurationNC = objRootDSE.Get("configurationNamingContext") objDebug.writeln "DONE:ConfigNC=" & strConfigurationNC,6 objDebug.write "Searching für Exchange Org using ADODB" Set oConnection = CreateObject("ADODB.Connection") Set oCommand = CreateObject("ADODB.Command") Set oRecordSet = CreateObject("ADODB.RecordSet") oConnection.Provider = "ADsDSOObject" oConnection.Open "ADs Provider" strQuery = ";" & _ "(objectclass=msExchOrganizationContainer);"& _ "name,distinguishedName,msExchMixedMode" objDebug.write "LDAP-String" & strQuery oCommand.ActiveConnection = oConnection oCommand.CommandText = strQuery Set oRecordSet = oCommand.Execute objDebug.writeln "DONE: record found :" & oRecordSet.recordcount, 4 if oRecordSet.EOF then objDebug.writeln "Unable to read Exchange Organization, Check AD-permissions.", 1 ExchangeOrg = "" else select case lcase(question) case "name" objDebug.writeln "Exchange Orgname =" & oRecordSet.Fields("name"), 3 ExchangeOrg = oRecordSet.Fields("name") case "dn" objDebug.writeln "FOUND dn =" & oRecordSet.Fields("distinguishedName"), 3 ExchangeOrg = oRecordSet.Fields("distinguishedName") case "mixed" objDebug.writeln "MixedMode=" & oRecordSet.Fields("msExchMixedMode"), 3 ExchangeOrg = oRecordSet.Fields("msExchMixedMode") case else objDebug.writeln "ExchangeOrg: wrong question specified. Was:" & question, 1 ExchangeOrg = "" end select end if end function 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 "" 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 "DebugWriter Output" objIE.document.write "" end if strieline = "" Select Case intseverity Case 0 strieline = strieLine & "" Case 1 strieline = strieLine & "" Case 2 strieline = strieLine & "" Case 3 strieline = strieLine & "" Case Else strieline = strieLine & "" End Select strieline = strieline & "" 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 class XMLTextWriter '~ Version 2.4 '~ 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 "" & vbcrlf private Sub Class_Initialize dim xmldeclaration Set xmlDom = CreateObject("Microsoft.XMLDOM") xmlDom.loadxml "" 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 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ä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ö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 ("" & vbcrlf & _ "" & vbcrlf & _ "" & vbcrlf & _ "" & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ "" & vbcrlf & _ "") getFormattedXML = xmlDOM.transformNode(oStylesheet) end function sub close() 'xmldom.LoadXML getFormattedXML xmldom.save(xmlfilename) end sub end class 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
TimeintseverityDescription
" & now () & "Out0Err1Wrn2Inf3Dbg"&intseverity&"" & strmessage & "