Option Explicit '------------------------------------------------------------------------- ' RGADMap.vbs ' ' Beschreibung ' Mit Exchange 2007 werden die AD Sites und Sitelinks zum Routing genutzt ' Aber auch heute ist es ein "gutes Design" wenn beide Einstellungen passen ' ' Das Script macht folgende ' - Liest alle AD Sites mit ihren Subnetzen aus ' - liest alle Exchange Server und deren IP-Adressen ' ' Generiert eine Liste: Exchangserver, AD Site, Routinggroup ' ' Später auch "Matchen" der Connectoren möglich ' ' Das Skript wird mit den Berechtigungen des angemeldeten Benutzers ' ausgeführt. Die entsprechenden Berechtigungen sind sicher zu stellen ' ' ACHTUNG: Grenzen ' - Umgebungen mit mehr als 100 Servern in einer RG werden aktuell nicht ' unterstützt wg getex(msExchRoutingGroupMembersBL) ' - Alle Server müssen "PING"bar sein, um die IP-Adresse zu erhalten ' ' (c)2006 Net at Work Netzwerksysteme GmbH ' ' Windows XP oder Windows 2003 erforderlich wg WMIPING mit Win32_PingStatus ' ' Version 1.0 (22. Dec 2005) Frank Carius ' Erstes release ' Version 1.1 (22. Jun 2006) Frank Carius ' Trennung nach NOSITE und NOPING ' Version 1.2 (23. Jun 2006) Frank Carius ' XSLT Stylesheet kennzeichnet NOPING und NOSIRE farblich ' '------------------------------------------------------------------------- Dim total Dim strQuery, strOutFilePrefix dim objDebug, xmlwriter, count dim strsource, strtarget dim strServerName dim strServerIP dim clsADSite, clsADCache, clsExchange, clsWMIPing dim ExchangeServerDN, rgDN, rgmemberDN strOutFilePrefix = makefilename("RGADMap-" & Date() & "-" & Time()) ' common name of the output files without extension set objdebug = new DebugWriter objDebug.target = "file:6 console:5" ' 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 objDebug.writeln "RGADMap: gestartet", 0 set xmlWriter = new XmlTextWriter xmlWriter.filename = strOutFilePrefix & ".xml" xmlWriter.Indentation = 4 call xmlWriter.WriteStylesheet("RGADMap.xsl") call writexslt("RGADMap.xsl") call xmlWriter.WriteStartElement("RGADMap") call xmlWriter.WriteElementString("starttime1", now()) set clsADSite = new ADSites set clsADCache = new ADCache set clsExchange = new MSXFAQExchange set clsWMIPing = new WMIPing ' ' Walk though all Exchange Servers ' total = ubound(clsExchange.getAllServerListDN)+1 call xmlWriter.WriteElementString("total1", total) call xmlWriter.WriteElementString("starttime2", now()) for each ExchangeServerDN in clsExchange.getAllServerListDN objDebug.writeln "Object:" & total & ":" & left(ExchangeServerDN,30)&".." ,4 total = total - 1 call xmlWriter.WriteStartElement("server") call xmlWriter.WriteElementString("dn",ExchangeServerDN) strServerName = clsExchange.getServerName(ExchangeServerDN) call xmlWriter.WriteElementString("name",strServerName) strServerIP = clsWMIPing.Ping(strServerName) call xmlWriter.WriteElementString("ip",strServerIP) if strServerIP = "0.0.0.0" then call xmlWriter.WriteElementString("adsite","NOPING") else call xmlWriter.WriteElementString("adsite",clsADSite.getsiteforip(strServerIP)) end if call xmlWriter.WriteElementString("rgdn",clsExchange.getRGMembership(ExchangeServerDN)) call xmlWriter.WriteElementString("rg",clsADCache.GetProperty(clsExchange.getRGMembership(ExchangeServerDN),"name")) call xmlWriter.WriteEndElement() ' of ("RGADMap" next objDebug.writeln "Total Records skipped:" & total, 0 call xmlWriter.WriteElementString("total2", total) call xmlWriter.WriteElementString("endtime", now()) call xmlWriter.WriteEndElement() ' of ("RGADMap") objdebug.writeln "Write XML-Output",0 call xmlWriter.Close ' XML schreiben objdebug.writeln "RGADMap finished",0 WScript.quit(0) sub writexslt(strfilename) dim txtxsl txtxsl = _ " " & vbcrlf & _ "" & vbcrlf & _ "" & vbcrlf & _ "" & vbcrlf & _ "RGADMap Status" & vbcrlf & _ "" & vbcrlf & _ "

RGADMap Status

" & vbcrlf & _ "

Summary

" & vbcrlf & _ " " & vbcrlf & _ "" & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ "
Starttime
Endtime
# Sitelinks total
# Sitelinks skipped
" & vbcrlf & _ "
" & vbcrlf & _ "

Exchange Servers and corresponding AD Sites and Routinggroups

" & 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 & _ "
Server:IP:AD Site:Routinggroup:
" & 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 ADCache ' Small class to store all AD Results in a dictionary für caching these results. ' So i have not to do all that stuff in the main code and can use "straight forward development ' and still have sufficient performance dim dicADCache dim strCurrentDN dim objAD private Sub Class_Initialize set dicADCache = CreateObject("Scripting.dictionary") strCurrentDN = "" End Sub private Sub Class_Terminate set dicADCache = nothing End Sub sub Flush dicADCache.removeall end sub function getProperty(strDN, strProperty) dim value if not dicADCache.exists (strDN & "!MSXFAQ!" & strProperty) then if strDN <> strCurrentDN then ' bind requested object' '' wscript.echo "Bind:LDAP://" & strDN set objAD = GetObject("LDAP://" & strDN) strCurrentDN = strDN end if on error resume next value = objAD.get(strProperty) if err then value = "NOT FOUND" err.clear end if on error goto 0 dicADCache.add strDN & "!MSXFAQ!" & strProperty, value end if getProperty = dicADCache(strDN & "!MSXFAQ!" & strProperty) end function function getDirectProperty(strDN, strProperty) ' read wihtout cache also für arrays strCurrentDN = strDN 'wscript.echo "Bind:LDAP://" & strDN set objAD = GetObject("LDAP://" & strDN) on error resume next getDirectProperty = objAD.getex(strProperty) if err then getDirectProperty = "NOT FOUND" err.clear end if on error goto 0 end function function getArrayProperty(strDN, strProperty) ' read arrays dim temp if strDN <> strCurrentDN then ' bind requested object' '' wscript.echo "Bind:LDAP://" & strDN set objAD = GetObject("LDAP://" & strDN) strCurrentDN = strDN end if '' wscript.echo "strProperty" & strProperty '' wscript.echo "strDN" & strDN on error resume next temp = objAD.getex(strProperty) on error goto 0 select case vartype (temp) case vbarray, vbarray + vbvariant, vbarray + vbstring getArrayProperty = temp case vbstring getArrayProperty = array(temp) case vbempty, vbnull getArrayProperty = array("") case else getArrayProperty = array("") end select end function end class class ADSites ' Easy access to AD-Sitekonfiguration dim strRootDSE, oConnection, oRecordset, oCommand dim dictSubnet 'Contains IP-Networks and corresponding siteDN dim dictSites 'contains siteDN and shortname dim dictDC 'contains DCs dim dictSiteLink ' key= DN dim dictSiteLinkBridge ' key= DN private Sub Class_Initialize set dictSubnet = createobject("Scripting.dictionary") set dictSites = createobject("Scripting.dictionary") set dictDC = createobject("Scripting.dictionary") set dictSiteLink = createobject("Scripting.dictionary") set dictSiteLinkBridge =createobject("Scripting.dictionary") set strRootDSE = GetObject ("LDAP://rootDSE") call fillsites call fillsubnet call fillDC call fillSitelink call fillsitelinkbridge End Sub 'private Sub Class_Terminate 'End Sub private sub FillSites 'Fills internals data strukture' ' Load dictionary Object with DN and Sitename' dim oConnection, objRecordset, oCommand dim count objDebug.writeln "Querying AD für Sites" & strRootDSE.get ("configurationNamingContext") ,6 Set oConnection = CreateObject("ADODB.Connection") Set objRecordset = CreateObject("ADODB.Recordset") Set oCommand = CreateObject("ADODB.Command") oConnection.Provider = "ADsDSOObject" oConnection.Open "ADs Provider" oCommand.ActiveConnection = oConnection oCommand.Properties("Page Size") = 100 oCommand.CommandText = ";" _ & "(objectClass=site);"_ & "distinguishedName,name;subtree" Set objRecordset = oCommand.Execute objDebug.writeln "Done Total ADSites found:" & objRecordset.recordcount, 6 count = 0 do until objRecordset.EOF count = count + 1 objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6 dictSites.add objRecordset.Fields("distinguishedName").value, objRecordset.Fields("name").value objRecordset.MoveNext loop objdebug.writeln "ADSites loaded items " & count,0 end sub private sub FillSubnet 'Fills internals data strukture' dim oConnection, objRecordset, oCommand dim count objDebug.writeln "Querying AD für Subnets" & strRootDSE.get ("configurationNamingContext") ,6 Set oConnection = CreateObject("ADODB.Connection") Set objRecordset = CreateObject("ADODB.Recordset") Set oCommand = CreateObject("ADODB.Command") oConnection.Provider = "ADsDSOObject" oConnection.Open "ADs Provider" oCommand.ActiveConnection = oConnection oCommand.Properties("Page Size") = 100 oCommand.CommandText = ";" _ & "(objectClass=subnet);"_ & "cn,distinguishedName,siteObject;subtree" Set objRecordset = oCommand.Execute objDebug.writeln "Done Total Subnets found:" & objRecordset.recordcount, 6 count = 0 do until objRecordset.EOF count = count + 1 objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6 dictSubnet.add objRecordset.Fields("cn").value,objRecordset.Fields("siteObject").value objRecordset.MoveNext loop objdebug.writeln "ADSubnets loaded items " & count,0 end sub private sub FillDC 'Fills internals data strukture' dim oConnection, objRecordset, oCommand dim count objDebug.writeln "Querying AD für Subnets" & strRootDSE.get ("configurationNamingContext") ,6 Set oConnection = CreateObject("ADODB.Connection") Set objRecordset = CreateObject("ADODB.Recordset") Set oCommand = CreateObject("ADODB.Command") oConnection.Provider = "ADsDSOObject" oConnection.Open "ADs Provider" oCommand.ActiveConnection = oConnection oCommand.Properties("Page Size") = 100 oCommand.CommandText = ";" _ & "(objectClass=subnet);"_ & "cn,distinguishedName,siteObject;subtree" Set objRecordset = oCommand.Execute objDebug.writeln "Done Total Subnets found:" & objRecordset.recordcount, 6 count = 0 do until objRecordset.EOF count = count + 1 objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6 dictDC.add objRecordset.Fields("cn").value,objRecordset.Fields("siteObject").value objRecordset.MoveNext loop objdebug.writeln "DC loaded items " & count,0 end sub private sub FillSitelink 'Fills internals data strukture' dim oConnection, objRecordset, oCommand dim count objDebug.writeln "Querying AD für dictSiteLink" & strRootDSE.get ("configurationNamingContext") ,6 Set oConnection = CreateObject("ADODB.Connection") Set objRecordset = CreateObject("ADODB.Recordset") Set oCommand = CreateObject("ADODB.Command") oConnection.Provider = "ADsDSOObject" oConnection.Open "ADs Provider" oCommand.ActiveConnection = oConnection oCommand.Properties("Page Size") = 100 oCommand.CommandText = ";" _ & "(objectClass=sitelink);"_ & "cn,distinguishedName;subtree" Set objRecordset = oCommand.Execute objDebug.writeln "Done Total dictSiteLink found:" & objRecordset.recordcount, 6 count = 0 do until objRecordset.EOF count = count + 1 objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6 dictSiteLink.add objRecordset.Fields("distinguishedName").value,objRecordset.Fields("cn").value objRecordset.MoveNext loop objdebug.writeln "dictSiteLink loaded items " & count,0 end sub private sub FillSitelinkBridge 'Fills internals data strukture' dim oConnection, objRecordset, oCommand dim count objDebug.writeln "Querying AD für dictSiteLinkBrid ge" & strRootDSE.get ("configurationNamingContext") ,6 Set oConnection = CreateObject("ADODB.Connection") Set objRecordset = CreateObject("ADODB.Recordset") Set oCommand = CreateObject("ADODB.Command") oConnection.Provider = "ADsDSOObject" oConnection.Open "ADs Provider" oCommand.ActiveConnection = oConnection oCommand.Properties("Page Size") = 100 oCommand.CommandText = ";" _ & "(objectClass=sitelinkBridge);"_ & "cn,distinguishedName;subtree" Set objRecordset = oCommand.Execute objDebug.writeln "Done Total dictSiteLink found:" & objRecordset.recordcount, 6 count = 0 do until objRecordset.EOF count = count + 1 objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6 dictSiteLinkBridge.add objRecordset.Fields("distinguishedName").value,objRecordset.Fields("cn").value objRecordset.MoveNext loop objdebug.writeln "dictSiteLinkBridge loaded items " & count,0 end sub function getsitelistDN ' Returns a Array with all Site DNs' getsitelistDN = dictSites.keys end function function getsitelist ' Returns a Array with all Site names' getsitelist = dictSites.items end function function GetSiteName(strsite) ' Returns the name für a siteDN GetSiteDN = dictSites.item(strsite) end function function getsubnetlist ' Returns a Array with all subnets' getsubnetlist = dictSubnet.keys end function function getsitelinkListDN ' Returns a Array with all Sitelinks' getsitelinkListDN = dictSiteLink.keys end function function getsitelinkBridgeListDN ' Returns a Array with all Sitelinks' getsitelinkBridgeListDN = dictSiteLinkBridge.keys end function function GetSiteforIP (byval IPaddress) ' returns sitename für IP-Address' ' result is the AD Sitename für a given ip address' ' Based on IP2Site.vbs witten April 4, 2003 by Wayne Tilton Dim DecIPAddr, MaskBits, NumAddrs, LoIPAddr, HiIPAddr, SiteAddrs Dim SubnetContainer, Subnet dim SiteName sitename = "NOSITE" ' Default site name if no matches SiteAddrs = (2^31)-1 ' Really big range DecIPAddr = Dot2Dec(IPaddress) ' Convert supplied address to decimal für each subnet in dictsubnet.keys MaskBits = Split(Subnet,"/") ' Split IP addr from subnet mask NumAddrs = (2 ^ (32 - MaskBits(1))) - 1 ' Calc # addresses based on subnet mask LoIPAddr = Dot2Dec(MaskBits(0)) ' Get low end of IP range in decimal HiIPAddr = LoIPAddr + NumAddrs ' Calc high end of range by adding # add ' Check to see if IP is within this subnet range and if so that it's smallest subnet with that addr If DecIPAddr => LoIPAddr And DecIPAddr <= HiIPAddr And NumAddrs <= SiteAddrs then SiteName = dictsubnet.item(subnet) SiteName = dictsites.item(Sitename) SiteAddrs = NumAddrs ' Remember # addrs in this subnet End If next GetSiteforIP = SiteName End Function private Function Dot2Dec(IPAddress) 'PRIVATE ' Returns the decimal value of a dotted decimal IP address Dim Octets Octets = Split(IPAddress,".") Dot2Dec = (Octets(0)*(2^24)) + (Octets(1)*(2^16)) + (Octets(2)*(2^8)) + Octets(3) End Function end class class MSXFAQExchange ' Easy access to Exchange data dim strRootDSE, oConnection, oRecordset, oCommand dim dictAG 'Contains AD and corresponding DN dim dictRG 'Contains RG and corresponding DN dim dictServer 'Contains Server and corresponding DN dim dictRGMember ' contains Servername and Routinggroup private Sub Class_Initialize set dictAG = createobject("Scripting.dictionary") set dictRG = createobject("Scripting.dictionary") set dictServer = createobject("Scripting.dictionary") set dictRGMember = createobject("Scripting.dictionary") set strRootDSE = GetObject ("LDAP://rootDSE") call fillAG call fillRG call fillServer End Sub 'private Sub Class_Terminate 'End Sub private sub FillAG ' Load dictionary Object with DN and Sitename' dim oConnection, objRecordset, oCommand dim count objDebug.writeln "Querying AD für AG" & strRootDSE.get ("configurationNamingContext") ,6 Set oConnection = CreateObject("ADODB.Connection") Set objRecordset = CreateObject("ADODB.Recordset") Set oCommand = CreateObject("ADODB.Command") oConnection.Provider = "ADsDSOObject" oConnection.Open "ADs Provider" oCommand.ActiveConnection = oConnection oCommand.Properties("Page Size") = 100 oCommand.CommandText = ";" _ & "(objectClass=msExchAdminGroup);"_ & "distinguishedName,name;subtree" Set objRecordset = oCommand.Execute objDebug.writeln "Done Total Admingroups found:" & objRecordset.recordcount, 6 count = 0 do until objRecordset.EOF count = count + 1 objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6 dictAG.add objRecordset.Fields("distinguishedName").value, objRecordset.Fields("Name").value objRecordset.MoveNext loop objdebug.writeln "dictAG loaded " & count,0 end sub private sub FillRG ' Load dictionary Object with DN and Sitename' dim oConnection, objRecordset, oCommand dim count, server dim objRG, temp objDebug.writeln "Querying AD für RG" & strRootDSE.get ("configurationNamingContext") ,6 Set oConnection = CreateObject("ADODB.Connection") Set objRecordset = CreateObject("ADODB.Recordset") Set oCommand = CreateObject("ADODB.Command") oConnection.Provider = "ADsDSOObject" oConnection.Open "ADs Provider" oCommand.ActiveConnection = oConnection oCommand.Properties("Page Size") = 100 oCommand.CommandText = ";" _ & "(objectClass=msExchRoutingGroup);"_ & "distinguishedName,name;subtree" Set objRecordset = oCommand.Execute objDebug.writeln "Done Total Admingroups found:" & objRecordset.recordcount, 6 count = 0 do until objRecordset.EOF count = count + 1 objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6 dictRG.add objRecordset.Fields("distinguishedName").value, objRecordset.Fields("Name").value ' Build Server to Routinggroup' set objRG = GetObject("LDAP://" & objRecordset.Fields("distinguishedName").value) on error resume next temp = objRG.get("msExchRoutingGroupMembersBL") if err then err.clear else select case vartype (temp) case vbarray, vbarray + vbvariant, vbarray + vbstring für each server in temp dictRGMember.add server, objRecordset.Fields("distinguishedName").value next case vbstring dictRGMember.add temp, objRecordset.Fields("distinguishedName").value case else end select end if on error goto 0 objRecordset.MoveNext loop objdebug.writeln "dictRG loaded " & count,0 end sub private sub FillServer ' Load dictionary Object with DN and Sitename' dim oConnection, objRecordset, oCommand dim count objDebug.writeln "Querying AD für Sites" & strRootDSE.get ("configurationNamingContext") ,6 Set oConnection = CreateObject("ADODB.Connection") Set objRecordset = CreateObject("ADODB.Recordset") Set oCommand = CreateObject("ADODB.Command") oConnection.Provider = "ADsDSOObject" oConnection.Open "ADs Provider" oCommand.ActiveConnection = oConnection oCommand.Properties("Page Size") = 100 oCommand.CommandText = ";" _ & "(&(objectClass=msExchExchangeServer)(!(objectClass=msExchExchangeServerPolicy)));"_ & "distinguishedName,name;subtree" Set objRecordset = oCommand.Execute objDebug.writeln "Done Total Admingroups found:" & objRecordset.recordcount, 6 count = 0 do until objRecordset.EOF count = count + 1 objDebug.writeln "Object:" & count & "/" & objRecordset.recordcount &":" & left(objRecordset.Fields("distinguishedName"),30)&".." ,6 dictServer.add objRecordset.Fields("distinguishedName").value, objRecordset.Fields("name").value objRecordset.MoveNext loop objdebug.writeln "dictServer loaded " & count,0 end sub function getAllServerListDN getAllServerListDN = dictServer.keys end function function getServerName (ServerDN) getServerName = dictServer.item(ServerDN) end function function getRGlist getRGlist = dictRG.keys end function function getRGMembership(serverDN) getRGMembership = dictRGMember.item(serverDN) end function function getAGList getAGList = dictAG.keys end function end class class XMLTextWriter '~ Version 2.2 '~ 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, 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 class debugwriter ' Generic Class für writing debugging information and handling runtime errors ' By default al Level 1 Messaegs are logged to the Console ' Version 29. Mar 2006 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 class WMIPing dim objWMIService private Sub Class_Initialize Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2") End Sub Function Ping(strTarget) ' Returns reply IP-Address if found dim colPings, objPing Set colPings = objWMIService.ExecQuery ("Select * From Win32_PingStatus where Address = '" & strTarget & "'") '' wscript.echo "Ping " & strTarget If Err = 0 Then Err.Clear für Each objPing in colPings If Err = 0 Then Err.Clear If objPing.StatusCode = 0 Then Ping = objPing.ProtocolAddress Else Ping = "0.0.0.0" End If Else Err.Clear End If Next Else Err.Clear Ping = "0.0.0.0" End If End Function end class 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 OctetToGUIDStr (arrbytOctet) ' Function to convert OctetString (byte array) to GUID string. ' based on Code from Richard Mueller, a MS MVP in Scripting and ADSI Dim k,strtemp OctetToGUIDStr = "" For k = 1 To Lenb (arrbytOctet) OctetToGUIDStr = OctetToGUIDStr & Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2) Next '~ In FB72F95DB430704983082BB1C79FFB38 '~ Out {5DF972FB-30B4-4970-8308-2BB1C79FFB38} strtemp= "{" strtemp = strtemp & mid(OctetToGUIDStr,7,2) strtemp = strtemp & mid(OctetToGUIDStr,5,2) strtemp = strtemp & mid(OctetToGUIDStr,3,2) strtemp = strtemp & mid(OctetToGUIDStr,1,2) strtemp = strtemp & "-" strtemp = strtemp & mid(OctetToGUIDStr,11,2) strtemp = strtemp & mid(OctetToGUIDStr,9,2) strtemp = strtemp & "-" strtemp = strtemp & mid(OctetToGUIDStr,15,2) strtemp = strtemp & mid(OctetToGUIDStr,13,2) strtemp = strtemp & "-" strtemp = strtemp & mid(OctetToGUIDStr,17,4) strtemp = strtemp & "-" strtemp = strtemp & mid(OctetToGUIDStr,21,12) OctetToGUIDStr = strtemp & "}" End Function
TimeintseverityDescription
" & now () & "Out0Err1Wrn2Inf3Dbg"&intseverity&"" & strmessage & "