Option Explicit '------------------------------------------------------------------------- ' DumpSPN ' ' Beschreibung ' Das Programm exportiert alle "ServicePrincipalNames" ' Warnt bei Dubletten ' (c)2006 Net at Work Netzwerksysteme GmbH ' ' Version 1.0 (14 Mai 2007) Frank Carius Dim xmlwriter, strGCPath Dim oConnection, oCommand, oRecordset Dim strQuery, strOutFilePrefix Dim dictSPN, strLocality Dim total strOutFilePrefix = makefilename("DumpSPN-" & Date() & "-" & Time()) ' Pfad und Dateiname der Log-Datei Dim objDebug Set objDebug = New DebugWriter objDebug.target = "file:6 console:4" ' 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 "DumpSPN: gestartet", 0 Set xmlwriter = New XmlTextWriter Call writexslt("DumpSPN.xsl") ' Stylesheet schreiben xmlwriter.filename = strOutFilePrefix & ".xml" xmlwriter.Indentation = 4 Call xmlwriter.WriteStylesheet("DumpSPN.xsl") Call xmlwriter.WriteStartElement("DumpSPN") Call xmlwriter.WriteElementString("starttime", Now()) Dim csvfile Set csvfile = New clsCSVWriter csvfile.OpenFile strOutFilePrefix & ".csv",csvfile.Overwrite ' Overwrite csvfile.Delimiter = ";" '~ csvfile.Quote = "'" csvfile.WriteRawLine("# DumpSPN - Created with MSXFAQ.CSVWriter") csvfile.AddHeader "spn" : csvfile.AddHeader "dn" : csvfile.AddHeader "status" csvfile.WriteHeader("") objDebug.writeln "Looking für GC",5 Dim oCont, oGC Set oCont = GetObject("GC:") For Each oGC In oCont strGCPath = oGC.ADsPath Next objDebug.writeln "strGCPath=" & strGCPath, 3 objDebug.writeln "Querying AD für Objects" & strGCPath,0 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 = "<" & strGCPath & ">;(ServicePrincipalName=*);distinguishedName,displayName,ServicePrincipalName;subtree" Set oRecordset = oCommand.Execute objDebug.writeln "Done Total Records found:" & oRecordset.recordcount, 0 Call xmlwriter.WriteElementString("starttime2", Now()) total = 0 Set dictSPN = CreateObject("scripting.dictionary") Dim strSPN, arrSPN, strDN, strStatus Do until oRecordset.EOF strStatus = "OK" strDN = oRecordset.Fields("distinguishedName").Value objDebug.writeln "Object:" & total & "/" & oRecordset.recordcount &":" & Left(strDN,20)&"..",3 total = total + 1 Call xmlwriter.WriteStartElement("object") Call xmlwriter.WriteElementString("dn", strDN) arrSPN = ToArray(oRecordset.Fields("ServicePrincipalName").value) For Each strSPN In arrSPN objDebug.writeln " SPN Found:" & strSPN,3 Call xmlwriter.WriteElementString("spn", strSPN) If dictSPN.exists (LCase(strSPN)) Then objDebug.writeln " SPN DUPLICATE:" & strSPN & " with " & dictSPN.Item(LCase(strSPN)), 2 strStatus = "DuplicateSPN with " & dictSPN.Item(lcase(strSPN)) Else objDebug.writeln " SPN Found:" & strSPN,3 dictSPN.Add LCase(strSPN), strDN strStatus = "OK" End If csvfile.StartLine csvfile.AddField "dn", strDN csvfile.AddField "spn",strSPN csvfile.AddField "status",strStatus csvfile.Writeline 'Zeile rausschreiben Next If dictSPN.exists (strLocality) Then dictSPN.item(strLocality ) = dictSPN.item(strLocality) + 1 objDebug.writeln "Dict INC:" & strLocality & "-" & dictSPN.item(strLocality),6 Else dictSPN.add strLocality, "1" objDebug.writeln "Dict ADD:" & strLocality,6 End If Call xmlwriter.WriteElementString("status", strStatus) Call xmlwriter.WriteEndElement ' of ("object") oRecordset.MoveNext Loop objDebug.writeln "Dump SPN",0 Call xmlwriter.WriteElementString("starttime3", Now()) Dim arrKeys, count arrKeys = dictSPN.keys For count = 0 To dictSPN.count - 1 Call xmlwriter.WriteStartElement("locality") Call xmlwriter.WriteElementString("name", arrKeys(count)) '~ on error resume next If dictSPN.exists (arrKeys(count)) Then Call xmlwriter.WriteElementString("count", dictSPN.item(arrKeys(count))) Else Call xmlwriter.WriteElementString("count", "0") End If Call xmlwriter.WriteEndElement ' of ("policy") Next Call xmlwriter.WriteElementString("total", total) objDebug.writeln "Total objects checked:" & total, 0 Call xmlwriter.WriteElementString("endtime", Now()) Call xmlwriter.WriteEndElement() ' of ("DumpSPN") Call xmlwriter.Close ' XML schreiben WScript.quit(0) Sub writexslt(strfilename) Dim txtxsl txtxsl = _ " " & VbCrLf & _ "" & VbCrLf & _ "" & VbCrLf & _ "" & VbCrLf & _ "DumpSPN Status" & VbCrLf & _ "" & VbCrLf & _ "

DumpSPN Status

" & VbCrLf & _ "

Summary

" & VbCrLf & _ " " & VbCrLf & _ "" & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ "
Starttime
Start Verarbeitung
EndTime
# Objects
" & VbCrLf & _ "
" & VbCrLf & _ "

Service Principal Names

" & VbCrLf & _ "" & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & VbCrLf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & VbCrLf & _ "" & VbCrLf & _ "
DistinguishedName:Service Principal Name:Status:
" & 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 Class clsCSVWriter ' Class to write generic CSVFiles ' Version 1.1 WriteHeader + Prefix, WriteRawLine ' Version 1.0 Initial Version ' Last Modified: 22. Nov 2006 ' Pending: Quotataion of '"'-Character in Data !! Private csvfilename, csvfs, csvfile, chrDelimiter, chrQuote, strline Private dictLine Private Sub Class_Initialize chrDelimiter =";" : chrQuote = """" : csvfilename = "" Set dictLine = CreateObject("scripting.dictionary") End Sub Public Property Let Delimiter (wert) ' Konfigure the delimiter. Default is ";" chrDelimiter =wert End Property Public Property Let Quote(wert) ' Konfigure the sting enquoting. Default is " chrQuote = wert End Property Public Property Get Overwrite ' Contant für Filemode Overwrite = 2 End Property Public Property Get Append ' Contant für Filemode Overwrite = 8 End Property Sub OpenFile(wert,intFileMode) ' Open and start a new CSV-File If csvfilename <> "" Then 'Close existing debug file csvfile.close : csvfile = Nothing : csvfs = Nothing End If csvfilename = wert ' open debug file Set csvfs = CreateObject("Scripting.FileSystemObject") Set csvfile = csvfs.OpenTextFile(csvfilename, intFileMode, True) End Sub Sub AddHeader(strvalue) ' Add a new column to the csv dataset If dictLine.exists(strvalue) Then objDebug.writeln "CSVWriter: duplicate Header definition:" & strvalue, 1 Else dictLine.add strvalue, Empty End If End Sub Sub WriteHeader(strPrefix) ' Write the current Header Definition to the file. optional with a prefix ' Prefix can be used to fake IISLogs with "# Field: " Dim key, strline strline = "" For Each key In dictLine.keys If strline <> "" Then strline = strline & chrDelimiter End If strline = strline & chrQuote & CStr(key) & chrQuote Next csvfile.WriteLine(strPrefix & strline) End Sub Sub AddField(strfieldname,strvalue) ' add a valuue together with the field name If dictLine.exists(strfieldname) Then dictLine.item(strfieldname) = strvalue Else objDebug.writeln "CSVWriter: Field not declared:" & strfieldname, 1 End If End Sub Sub WriteLine ' Write the current filled fields to the disk and starte a new line Dim key, strline strline = "" For Each key In dictLine.keys If strline <> "" Then strline = strline & chrDelimiter End If strline = strline & chrQuote & dictLine(key) & chrQuote dictLine.item(key) = Empty Next csvfile.WriteLine(strline) End Sub Sub WriteRawLine(strLine) ' Write line without any formatting etc. Ideal für comments and other custom output csvfile.WriteLine(strline) End Sub Sub StartLine ' Start a new line. Remove all existing data of the current line Dim key, strline strline = "" For Each key In dictLine.keys dictLine.item(key) = Empty Next End Sub 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 Function ToArray(wert) ' Converts value to array of string. ' Array -> Array ' Sring -> Array(0) ' null -> Array -1 Dim arrtemp() Dim count Select Case VarType(wert) Case vbArray, vbArray + vbVariant, vbArray + vbString ReDim arrTemp(UBound(wert)) For count = 0 To uBound(wert) objDebug.writeln "ToArray:" & count & "-" & wert(count) , 7 arrTemp(count) = wert(count) Next Case vbString ReDim arrTemp(0) arrTemp(0) = wert Case vbEmpty, vbNull ReDim arrTemp(-1) Case Else ReDim arrTemp(-1) objDebug.writeln "ToArray:unbekannt Vartype:" & VarType(wert), 1 End Select ToArray = arrTemp End Function
TimeintseverityDescription
" & Now () & "Out0Err1Wrn2Inf3Dbg"&intseverity&"" & strMessage & "