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 = _ " " & VbCrLf & _ "" & VbCrLf & _ "" & VbCrLf & _ "" & VbCrLf & _ "AltRecipient Status" & VbCrLf & _ "" & VbCrLf & _ "

AltRecipient Status

" & VbCrLf & _ "

Summary

" & VbCrLf & _ " " & VbCrLf & _ "" & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ "
Start Verarbeitung
Start Process Objects
EndTime
#Total Recipients checked
" & VbCrLf & _ "
" & VbCrLf & _ "

Objects

" & VbCrLf & _ "" & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ "" & VbCrLf & _ "
DisplayName:Mail:AltRecipientMail:Status:
" & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ "
" & VbCrLf & _ "" & VbCrLf & _ "" & VbCrLf & _ "
" & VbCrLf & _ "
" 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 "" & 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 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ä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ö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 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 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
TimeintseverityDescription
" & Now () & "Out0Err1Wrn2Inf3Dbg"&intseverity&"" & strMessage & "