Option Explicit '------------------------------------------------------------------------- ' RUSMON.1.1.vbs ' ' Beschreibung: ueberwacht das Eventlog auf Meldungen des RUS über geänderte Benutzer ' In einer Textdatei, dem eventlog und dem Bildschirm werden alle änderungen protkolliert ' Der RUS fügt immer nur neue Adressen hinzu. Im Log stéht NICHT, wenn eine Primäre zur sekundären wird ' sondern nur, dass der User eine neue Primäre Adresse erhalten hat. Damit ist klar, dass die bisherige sekundär ist ' Löschungen von SMTP-Adressen durch einen Administrator können nicht erkannt werden. ' ' 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)2004 Net at Work Netzwerksysteme GmbH ' ' Version 1.0 (20. April 2005) ' + Erste Version ' Version 1.1 (23. April 2005) ' + SuchStrings als Kontanten zum Anpassen ' Version 1.2 (10. Feb 2006) ' + Diagnoselog prüfug bei Monitor Mode erzwingen. ' Version 1.3 (19. Oct 2006) ' XMLWriter und Debuglog ' ' offen ' + Bessrere Syntaxanalyse (Mehrsprachig) fuer Application, MSExchangeSA Event 3006 '------------------------------------------------------------------------- Dim colMonitoredEvents, colLoggedEvents 'Collection der Eventmeldungen Dim objWMIService 'WMI Objekt für Zugriff auf Eventlog Dim objLatestEvent, objEvent 'Object für den jeweiligen Event Dim Eventmessage Dim chrcommand 'Auszuführender Befehl Dim objShell ' für Eventlog dim strOutFilePrefix strOutFilePrefix = makefilename("RUSMON-" & Date() & "-" & Time()) ' common name of the output files without extension dim objDebug set objdebug = new DebugWriter objDebug.target = "file:5 console:5" '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 If WScript.Arguments.count= 0 Then ' Bestimmten der Kommandozeile chrcommand = "H" Else chrcommand = lcase(Left(WScript.Arguments.item(0),1)) End If dim xmlWriter set xmlWriter = new XmlTextWriter xmlWriter.filename = strOutFilePrefix & ".xml" xmlWriter.Indentation = 4 call xmlWriter.WriteStylesheet("rusmon.xsl") '~ call writexslt("rusmon.xsl") call xmlWriter.WriteStartElement("rusmon") call xmlWriter.WriteElementString("starttime", now()) call xmlWriter.flush Set objShell = WScript.CreateObject("Wscript.Shell") ' für Eventlog und Registry Select Case chrcommand Case "m" 'MonitorMode Eventlog überwachen call xmlWriter.WriteElementString("mode", "monitor") If objShell.RegRead("HKLM\SYSTEM\CurrentControlSet\Services\MSExchangeSA\Diagnostics\16 Proxy Generation") < 5 Then objDebug.writeln "Error: RUS-Debugging ist nicht aktiv. Bitte Diagnoseprotokoll MSExchangeSA\Proxygeneration auf MAX stellen",1 Else objDebug.writeln "Debugging ist aktiv OK",2 Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2") ' WMI verbinden Set colMonitoredEvents = objWMIService.ExecNotificationQuery _ ("Select * from __instancecreationevent where TargetInstance isa 'Win32_NTLogEvent' " & _ "and TargetInstance.LogFile = 'Application' " & _ "and TargetInstance.SourceName = 'MSExchangeSA' " & _ "and TargetInstance.EventCode = '3006' ") objDebug.writeln "Waiting für events...",1 objDebug.writeln "Flush XML",5 Do 'Endlosschleife Set objLatestEvent = colMonitoredEvents.NextEvent objDebug.writeln "Event found",4 Call processEvent(evtdatetime(objLatestEvent.TargetInstance.TimeGenerated), objLatestEvent.TargetInstance.Message) objDebug.writeln "Flush XML",5 call xmlWriter.flush objDebug.writeln "Event processed",4 Loop End If Case "s" 'ScanMode. bestehendes Eventlos absuchen call xmlWriter.WriteElementString("mode", "scan") Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2") Set colLoggedEvents = objWMIService.ExecQuery _ ("Select * from Win32_NTLogEvent where LogFile = 'Application' " & _ "and SourceName = 'MSExchangeSA' " & _ "and EventCode = '3006' ") dim countx For Each objEvent In colLoggedEvents objDebug.writeln "Event found",0 Call processEvent(evtdatetime(objEvent.TimeGenerated), objEvent.Message) objDebug.writeln "Flush XML",5 call xmlWriter.flush Next Case Else ' Hilfe anzeigen call xmlWriter.WriteElementString("mode", "help") objDebug.writeln "HELP: Bitte mit M oder S aufrufen", 0 objDebug.writeln "HELP: M=Monitore Eventlog auf neue Einträge", 0 objDebug.writeln "HELP: S=Scanne bestehendes Eventlog", 0 End Select call xmlWriter.WriteElementString("endtime", now()) call xmlWriter.WriteEndElement ' of RUSMIN call xmlWriter.close objDebug.writeln "Skript beendet", 0 WScript.quit(0) Sub processEvent(strtime, strMessage) ' Verarbeite den anliegenden Event Dim strUserDN, strmail ' Dim strnewproxy, stroldproxy ' Alte und neue Mailadressen Dim arrnewproxy ' temporäres Array objDebug.writeln "ProcessEvent:--------------------------------", 0 ' & strMessage if instr(strMessage,"Aktuelle Empfängerproxys:" ) > 0 then objDebug.writeln "Language = DE", 5 strUserDN = Mid(strMessage,InStr(strMessage,"Empfänger-DN: ")+14) ' bearbeitetes Objekt ermitteln strUserDN = Mid(strUserDN,1,InStr(strUserDN,vbCrLf)-1) ' String am Zeilenende abschneiden stroldproxy = GetProxy ("Aktuelle Empfängerproxys:" , strMessage) ' "Current recipient proxies:" strnewproxy = GetProxy ("Für den Empfänger geschriebene Proxys:", strMessage) '"Proxies written to recipient:" elseif instr(strMessage, "Current recipient proxies:") > 0 then objDebug.writeln "Language = EN", 5 strUserDN = Mid(strMessage,InStr(strMessage,"Recipient DN: ")+14) ' bearbeitetes Objekt ermitteln strUserDN = Mid(strUserDN,1,InStr(strUserDN,vbCrLf)-1) ' String am Zeilenende abschneiden stroldproxy = GetProxy ("Current recipient proxies:" , strMessage) ' "Current recipient proxies:" strnewproxy = GetProxy ("Proxies written to recipient:", strMessage) '"Proxies written to recipient:" else objDebug.writeln "Unable to detect LANGUAGE", 1 strnewproxy ="Unable to detect LANGUAGE. Please extend script definition" end if objDebug.writeln "UserDN:" & strUserDN,3 objDebug.writeln "ALT:"& vbCrLf & stroldproxy,3 objDebug.writeln "NEW:"& vbCrLf & strnewproxy,3 arrnewproxy = Split(strnewproxy,vbCrLf) call xmlWriter.WriteStartElement("object") call xmlWriter.WriteElementString("date", strtime) call xmlWriter.WriteElementString("dn", strUserDN) For Each strmail In arrnewproxy objDebug.writeln "Check:" & strmail,3 If InStr(stroldproxy,strmail)=0 Then ' änderung protokollieren. objDebug.writeln strtime & ";"& strUserDN &";Change:" & strmail,0 call xmlWriter.WriteElementString("mail", strmail) objShell.LogEvent 0, "Time:"& strtime & vbCrLf &"DN:"& strUserDN & vbCrLf &"Proxy:"& strmail 'conEVENT_SUCCESS End If Next call xmlWriter.WriteEndElement End Sub Function GetProxy (strstart, strQuelle) ' erhält einen MultilineString und extrahiert die Mailadressen in einen String Dim strtemp, arrtemp, strline, count objDebug.writeln "Start:"&strstart,5 objDebug.writeln "Quelle:"&strQuelle,5 strtemp = Mid(strQuelle,InStr(strQuelle,strstart)) objDebug.writeln "Temp:"&strtemp,5 arrtemp = Split(strtemp,vbCrLf) strtemp="" For count = 1 To uBound(arrtemp) 'erste Zeile überspringen Call objDebug.writeln (3,"->"&arrtemp(count)&"<-") Select Case Left(arrtemp(count),1) Case " ",vbTab ' hier steht, was passieren soll, wenn die erste Bedingung wahr ist strtemp = strtemp + Trim(arrtemp(count))+vbCrLf 'Einrückung entfernen objDebug.writeln "LOOPLine="& Trim(arrtemp(count)),5 Case Else Exit For End Select Next objDebug.writeln "strTemp="&strtemp,5 If Len(strtemp)<>0 Then GetProxy = Left(strtemp,Len(strtemp)-1) ' letztes vbcrlf abschneiden End If objDebug.writeln "GetProxy="&strtemp,5 End Function Function evtdatetime(evttime) ' Auszug aus http://www.sadikhov.com/forum/Assistance-Requested-On-Vbscript_13254.html ' Konvertiert die Datum/Zeit Informationdes Eventlog in ein lesbares Format. Dim tmGen, dtPart,tmPart,strDt tmGen = evttime & "" dtPart = Mid(tmGen,1,8) tmPart = Mid(tmGen,9,6) strDt = Mid(dtPart,5,2) & "/" & Mid(dtPart,7,2) & "/" & Mid(dtPart,1,4) & " " & _ Mid(tmPart,1,2) & ":" & Mid(tmPart,3,2) & ":" & Mid(tmPart,5,2) evtdatetime = FormatDateTime(strDt,0) 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 & "