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 for 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 for 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 = _
		"<?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>DumpSPN Status</title></head>" & VbCrLf & _
		"<body>" & VbCrLf & _
		"<h1>DumpSPN Status</h1> " & VbCrLf & _
		"<h2>Summary</h2> " & VbCrLf & _
		"<xsl:for-each select=""DumpSPN""> " & VbCrLf & _
		"<table border=""1"" width=""100%"">" & VbCrLf & _
		"	<tr><th>Starttime</th><td><xsl:value-of select=""starttime"" /></td></tr>" & VbCrLf & _
		"	<tr><th>Start Verarbeitung</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># Objects</th><td bgcolor=""#FFFFFF""><xsl:value-of select=""total""/></td></tr>" & VbCrLf & _
		"</table>" & VbCrLf & _
		"</xsl:for-each>" & VbCrLf & _
		"<h2>Service Principal Names</h2> " & VbCrLf & _
		"<table border=""1"" width=""100%"">" & VbCrLf & _
		"  <tr bgcolor=""#808080"">" & VbCrLf & _
		"	<th>DistinguishedName:</th> " & VbCrLf & _
		"	<th>Service Principal Name:</th> " & VbCrLf & _
		"	<th>Status:</th> " & VbCrLf & _
		"  </tr>" & VbCrLf & _
		"<xsl:for-each select=""DumpSPN/object""> " & VbCrLf & _
		"	<tr>" & VbCrLf & _
		"	<td>" & VbCrLf & _
		"		<xsl:value-of select=""dn"" /> " & VbCrLf & _
		"	</td>" & VbCrLf & _
		"	<td>" & VbCrLf & _
		"		<xsl:for-each select=""spn""><xsl:value-of select=""."" /><br /></xsl:for-each>" & vbcrlf & _
		"	</td>" & VbCrLf & _
		"	<xsl:choose>" & vbcrlf & _
		"		<xsl:when test=""status='OK'"">" & vbcrlf & _
		"			<td bgcolor=""#00ff00"">" & vbcrlf & _
		"			<xsl:value-of select=""status"" /> " & vbcrlf & _
		"			</td>" & vbcrlf & _
		"		</xsl:when>" & vbcrlf & _
		"		<xsl:otherwise>" & vbcrlf & _
		"			<td bgcolor=""#c0c0c0"">" & 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 for 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 ("<?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 for 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

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 for Filemode
		Overwrite = 2
	End Property

	Public Property Get Append
	' Contant for 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 for 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