Option Explicit '------------------------------------------------------------------------- ' grp2exinet.vbs 4.0 ' ' DEscription: ' ' Evaluated several group memberships to set exchange protocol permissions ' POP3, IMAP, OWA, OMA: User must be member of the approbiate group to have access (Allow only member) ' MAPI and CacheOnly: Members of the NoMapi or CacheOnly Group are restricted. Others are not ! (disallow only members) ' I made that, because POP3, IMAP4 etc. are off by default (Exchange 2003) but mapi is "on" by default ' ' Runtime error are not controlled. So check, if the script runs correctly ' The script uses the permission of the calling User. Make sure that you have enough permissions ' ' (c)2004 Net at Work Netzwerksysteme GmbH ' ' Version 1.0 (18. Apr 2005) ' + initial version ' + parsing all Users to chek, if they are member of ' Version 2.0 (20. April 2005) ' + separate groups für the protocols OWA, OMA, POP3, IMAP4 möglich ' + Put the group names into contants instead of command line ' Version 3.0 (17. Aug 2005) ' + Change output to XML ' + enhance debugging using my own class ' Version 3.1 (17. Aug 2005) ' + Output now divides between changed and unchanged fields ' + add the "action" to run in simulation mode ' Version 4.0 (21. Aug 2005) ' + Exchange 2003 SP2 extension to handle MAPI ' ' Feld "protocolSettings" ' Enumerating Exchange Object Properties With ADSI/ADO ' http://msdn.Microsoft.com/library/default.asp?URL=/library/en-us/e2k3/e2k3/_clb_enumerating_exchange_object_properties_with_adsi_ado_vb.asp ' Technet: ms-help://MS.TechNet.2005APR.1033/enu_kbexchange/exchange/252459.htm ' Enabling and disabling MAPI and/or non-Cached access per User in Exchange 2003 SP2 ' http://msexchangeteam.com//archive/2005/07/27/408274.aspx '------------------------------------------------------------------------- ' -------------------------------------------------------------- ' You have to enther your values here !!! ' -------------------------------------------------------------- Const conPOP3GRP = "cn=pop3group,ou=groups,dc=msxfaq,dc=local" ' Members can use POP3 Const conIMAP4GRP = "cn=imap4group,ou=groups,dc=msxfaq,dc=local" ' Members can User IMAP4 Const conOWAGRP = "cn=owagroup,ou=groups,dc=msxfaq,dc=local" ' Members can use OWA Const conOMAGRP = "cn=omagroup,ou=groups,dc=msxfaq,dc=local" ' Members can use OMA Const conNOMAPIGRP = "cn=nomapigroup,ou=groups,dc=msxfaq,dc=local" ' Members cannot use MAPI at all !! Const conMAPICACHEONLYGRP = "cn=mapicacheonlygroup,ou=groups,dc=msxfaq,dc=local" ' Members are enforced to use Cachedmode Const conDNSDomain = "dc=msxfaq,dc=local" ' BaseDN to search für Users. ' By default the script is running in "ReadOnly" Mode. You can check the XML-Output to verify the settings. ' if you are sure, that the script does, what you want, then set action to "true" Const action = "readonly" ' set to 'write' to enable writing 'const action = "write" ' ' ' -------------------------------------------------------------- ' NO NOT MODIFY AFTER THAT LINE !!! ' -------------------------------------------------------------- Const conExInetIMAP4off = "IMAP4???§DIN_66003????" Const conExInetIMAP4on = "IMAP4???§DIN_66003????" Const conExInetPOP3off = "POP3???§DIN_66003?§§? Const conExInetPOP3on = "POP3???§DIN_66003?§§? Const conExInetOWAoff = "HTTP??§§§§§§" Const conExInetOWAon = "HTTP??§§§§§§" Const conExInetMAPIoff = "MAPI??§§§§§§" ' disallow mapi access Const conExInetMAPIon = "MAPI??§§§§§§" 'allow any client Const conExInetMAPIcache = "MAPI??§§§§§§" ' deny non cached clients Const conExInetMobileon = "0" Const conExInetMobileoff= "7" ' OWA, ActiveSync is stored in "msExchOmaAdminWirelessEnable" ' bit 1 (1) = ActiveSync active notification ' bit 3 (4) = ActiveSync User initiierte Sync ' bit 2 (2) = OMA Access ' possible entries. 0,1,2,3,5,7 (4 and 6 are not valid) Const ADS_PROPERTY_CLEAR = 1 Const ADS_PROPERTY_UPDATE = 2 Const ADS_PROPERTY_APPEND = 3 Dim objCommand ,objConnection, objRecordSet, objRootDSE, objUser ' Dim strAttributes, strBase, strDN, strFilter, strGroupDN, strHomeMDB, strMDB, strQuery, strOutFilePrefix Dim XMLWriter Dim count, modified Dim objimap4Group, objomaGroup, objowaGroup, objpop3Group, objNOMapiGroup, objMapiCacheOnlyGroup ' Dim protocolSettings (3) ' Array für protocol settings Dim logging ' Dim protocol ' Dim strCurrentProtocol ' Dim Writeprotocol ' call ForceCScript ' must be rund with CSCRIPT call abbruch ("Continue script ?" ,5) ' Last question to stop ' ----- Initialisierung der Debugging und Loggingoptionen strOutFilePrefix = "grp2exinet-" & makefilename(Date() & "-" & Time()) ' complete file name für debug file dim objDebug set objdebug = new DebugWriter objDebug.target = "file:5 console:5 noie:0 noeventlog:0" ' errorlogging 0=only output, 1=Error 2=Warning 3=information 5++ =debug objDebug.outFile = WScript.ScriptName & "-" & Date() & "-" & Time() & ".log" objDebug.start objDebug.writeln "grp2exinet: Started", 0 set xmlWriter = new XmlTextWriter xmlWriter.filename = strOutFilePrefix & ".xml" xmlWriter.Indentation = 4 call xmlWriter.WriteStylesheet("grp2exinet.xsl") call writexslt("grp2exinet.xsl") call xmlWriter.WriteStartElement("grp2exinet") call xmlWriter.WriteElementString("starttime", now()) call xmlWriter.WriteElementString("action", ACTION) call xmlWriter.WriteElementString("grppop3", conPOP3GRP) call xmlWriter.WriteElementString("grpimap4", conIMAP4GRP) call xmlWriter.WriteElementString("grpowa", conOWAGRP) call xmlWriter.WriteElementString("grpoma", conOMAGRP) Set objpop3Group = GetObject("LDAP://" & conPOP3GRP) ' Gruppenobjekt binden Set objimap4Group = GetObject("LDAP://" & conIMAP4GRP) ' Gruppenobjekt binden Set objowaGroup = GetObject("LDAP://" & conOWAGRP) ' Gruppenobjekt binden Set objomaGroup = GetObject("LDAP://" & conOMAGRP) ' Gruppenobjekt binden Set objNoMapiGroup = GetObject("LDAP://" & conNOMAPIGRP) ' Gruppenobjekt binden Set objMapiCacheOnlyGroup = GetObject("LDAP://" & conMAPICACHEONLYGRP) ' Gruppenobjekt binden Set objCommand = CreateObject("ADODB.Command") ' mit ADO das Active Directory durchsuchen Set objConnection = CreateObject("ADODB.Connection") objConnection.Provider = "ADsDSOObject" objConnection.Open "Active Directory Provider" objCommand.ActiveConnection = objConnection strBase = "" ' Gesamte Domäne durchsuchen ' Filter für alle Exchange Postfächer (aus in Exchange 2003 angelegter Adressliste) strFilter = "(&(&(& (mailnickname=*)(| (&(objectCategory=person)(objectClass=User)(|(homeMDB=*)(msExchHomeServerName=*)))))))" strAttributes = "distinguishedName,msExchOmaAdminWirelessEnable,protocolSettings" ' Gesuchte Attribute strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree" ' LDAP query zusammenbauen objCommand.CommandText = strQuery objCommand.Properties("Page Size") = 100 ' max 100 Ergebnisse auf einmal erhalten 'objCommand.Properties("Timeout") = 30 ' Timeout 30 Sekunden 'objCommand.Properties("Cache Results") = False Set objRecordSet = objCommand.Execute ' und los objDebug.writeln "Total Objects to check:" & objrecordset.recordcount, 0 call xmlWriter.WriteElementString("totalfound", objrecordset.recordcount) count = 0 : modified = 0 Do until objRecordSet.EOF ' jeden Datensatz einzeln bearbeiten. writeprotocol = false call xmlWriter.WriteStartElement("object") strDN = objRecordSet.Fields("distinguishedName") ' DN ermitteln count = count + 1 objDebug.writeln "Processing:" & count & ":" & strDN, 4 Set objUser= GetObject("LDAP://" & strDN) ' User verbinden objDebug.writeln " - Object bound", 5 call xmlWriter.WriteElementString("dn", objUser.distinguishedname) call xmlWriter.WriteElementString("cn", objUser.cn) call xmlWriter.WriteElementString("name", objUser.name) strCurrentProtocol = "" if objRecordSet.Fields("protocolSettings").ActualSize <> 0 then strCurrentProtocol = Join(objRecordSet.Fields("protocolSettings").Value,",") objDebug.writeln "current protocol setting imported", 6 else objDebug.writeln "current protocol setting missing. first time creation", 6 end if If objimap4Group.IsMember("LDAP://" & strDN) Then ' IMAP4 protocolSettings(1)= conExInetIMAP4on objDebug.writeln " IMAP4 Enabled", 5 If InStr(strCurrentProtocol,conExInetIMAP4on) = 0 Then call xmlWriter.WriteElementString("imap4", "1!") Writeprotocol = True objDebug.writeln " Modified - Write required", 5 else call xmlWriter.WriteElementString("imap4", "1") end if Else protocolSettings(1)= conExInetIMAP4off objDebug.writeln " IMAP4 Disabled", 5 If InStr(strCurrentProtocol,conExInetIMAP4off) = 0 Then call xmlWriter.WriteElementString("imap4", "0!") Writeprotocol = True objDebug.writeln " Modified - Write required", 5 else call xmlWriter.WriteElementString("imap4", "0") end if End If If objpop3Group.IsMember("LDAP://" & strDN) Then ' POP3 objDebug.writeln " POP3 Enabled", 5 protocolSettings(0)= conExInetPOP3on If InStr(strCurrentProtocol,conExInetPOP3on) = 0 Then call xmlWriter.WriteElementString("pop3", "1!") Writeprotocol = True objDebug.writeln " Modified - Write required", 5 else call xmlWriter.WriteElementString("pop3", "1") end if Else protocolSettings(0)= conExInetPOP3off objDebug.writeln " POP3 Disabled", 5 If InStr(strCurrentProtocol,conExInetPOP3off) = 0 Then call xmlWriter.WriteElementString("pop3", "0!") Writeprotocol = True objDebug.writeln " Modified - Write required", 5 else call xmlWriter.WriteElementString("pop3", "0") end if End If If objowaGroup.IsMember("LDAP://" & strDN) Then ' HTTP protocolSettings(2)= conExInetOWAon ' Enable objDebug.writeln " OWA Enabled", 5 If InStr(strCurrentProtocol,conExInetOWAon) = 0 Then call xmlWriter.WriteElementString("owa", "1!") Writeprotocol = True objDebug.writeln " Modified - Write required", 5 else call xmlWriter.WriteElementString("owa", "1") end if Else protocolSettings(2)= conExInetOWAoff objDebug.writeln " OWA Disabled", 5 If InStr(strCurrentProtocol,conExInetOWAoff) = 0 Then call xmlWriter.WriteElementString("owa", "0!") Writeprotocol = True objDebug.writeln " Modified - Write required", 5 else call xmlWriter.WriteElementString("owa", "0") end if End If If objNomapiGroup.IsMember("LDAP://" & strDN) Then ' Check MAPI protocolSettings(3)= conExInetMAPIoff ' Disable MAPI objDebug.writeln " MAPI Disabled", 5 If InStr(strCurrentProtocol,conExInetMAPIoff) = 0 Then call xmlWriter.WriteElementString("mapi", "0!") 'switch off Writeprotocol = True objDebug.writeln " Modified - Write required", 5 else call xmlWriter.WriteElementString("mapi", "0") ' is already off end if Elseif objmapiCacheOnlyGroup.IsMember("LDAP://" & strDN) then protocolSettings(3)= conExInetMAPIcache ' Enable Cache Mode onlny objDebug.writeln " MAPI Cache Only", 5 If InStr(strCurrentProtocol,conExInetMAPIcache) = 0 Then call xmlWriter.WriteElementString("mapi", "C!") Writeprotocol = True objDebug.writeln " Modified - Write required", 5 else call xmlWriter.WriteElementString("mapi", "C") end if else protocolSettings(3)= conExInetMAPIon ' Enable full mapi access objDebug.writeln " MAPI enabled", 5 If InStr(strCurrentProtocol,conExInetMAPIon) = 0 Then call xmlWriter.WriteElementString("mapi", "1!") Writeprotocol = True objDebug.writeln " Modified - Write required", 5 else call xmlWriter.WriteElementString("mapi", "1") end if End If If objomaGroup.IsMember("LDAP://" & strDN) Then ' OMA objDebug.writeln " OMA Enabled", 5 If UCase(objRecordSet.Fields("msExchOmaAdminWirelessEnable").Value) <> UCase(conExInetMobileon) Then if action = "write" then objUser.Put "msExchOmaAdminWirelessEnable",conExInetMobileon objDebug.writeln " Modified - Write required", 5 Writeprotocol = True end if call xmlWriter.WriteElementString("oma", "1!") ' change setting Else call xmlWriter.WriteElementString("oma", "1") ' already enabled End If Else objDebug.writeln " OMA Disabled", 5 If UCase(objRecordSet.Fields("msExchOmaAdminWirelessEnable").Value) <> UCase(conExInetMobileoff) Then if action = "write" then objUser.Put "msExchOmaAdminWirelessEnable",conExInetMobileoff objDebug.writeln " Modified - Write required", 5 Writeprotocol = True end if call xmlWriter.WriteElementString("oma", "0!") ' Change to disable Else call xmlWriter.WriteElementString("oma", "0") ' already disabled End If End If If Writeprotocol Then objDebug.writeln " Writing modifications", 4 call xmlWriter.WriteElementString("action", "write") if action = "write" then objUser.PutEx ADS_PROPERTY_UPDATE, "protocolSettings",protocolSettings if action = "write" then objUser.setinfo ' Write modified = modified + 1 Else call xmlWriter.WriteElementString("action", "none") ' Nothing to do objDebug.writeln " No modifications", 4 End If objDebug.writeln "Done", 3 call xmlWriter.WriteEndElement() 'object objRecordSet.MoveNext ' Nächster Benutzer Loop call xmlWriter.WriteElementString("totalprocessed", count) objDebug.writeln "Total objects processed:" & count, 0 call xmlWriter.WriteElementString("totalmodified", modified) objDebug.writeln "# Modified:" & modified, 0 call xmlWriter.WriteElementString("endtime", now()) call xmlWriter.WriteEndElement() call xmlWriter.Close wscript.quit(0) sub writexslt(strfilename) dim txtxsl txtxsl = _ " " & vbcrlf & _ "" & vbcrlf & _ "" & vbcrlf & _ "" & vbcrlf & _ "grp2exinet Status" & vbcrlf & _ "" & vbcrlf & _ "

grp2exinet Status

" & vbcrlf & _ "

Parameters

" & vbcrlf & _ "" & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ "
Starttime
EndTime
Group für POP3
Group für IMAP4
Group für OWA
Group für OMA
Action
# Objects found
# Processed
# Modified
" & vbcrlf & _ "

Details

" & 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 & _ " " & 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 & _ " " & 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 & _ " " & 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 & _ "
CN:Name:POP3:IMAP4:OWA:OMA:MAPI:Modified
" & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " 01Unknown:01Unknown:01Unknown:01Unknown:01CUnknown:NoneUpdateUnknown:
" & 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 intIndentation dim level, tagopen dim Stack(100) ' i have problems using redim, so i use a fixed number für the depth dim fs, xmlfile private Sub Class_Initialize intIndentation = 4 level = 0 tagopen = false End Sub public Property let filename(wert) Set fs = CreateObject("Scripting.FileSystemObject") Set xmlfile = fs.OpenTextFile(wert, 2, True) ' 2 = ForWriting xmlfile.write "" & vbcrlf End Property public Property let Indentation(wert) intIndentation = wert End Property sub Writestylesheet (item) '* xmlfile.write "" & vbcrlf end sub sub WriteStartElement(item) xmlfile.write vbcrlf & space(intIndentation*level) & "<" & quote(trim(item)) ' & ">" ' Ende offen tagopen = true stack(level) = item level = level + 1 end sub sub WriteAttributeString(item,wert) ' ergänzt eine ID zum aktuellen Element if tagopen then xmlfile.write " id=""" & Quote(wert) & """" else wscript.echo "XMLWriter: Tag not open" wscript.quit(255) end if end sub sub WriteElementString(item,wert) ' wert if tagopen then xmlfile.write ">" : tagopen = false end if xmlfile.write vbcrlf & space(intIndentation*level) xmlfile.write "<" & quote(trim(item)) & ">" xmlfile.write quote(wert) xmlfile.write "" end sub sub WriteEndElement if tagopen then xmlfile.write ">" : tagopen = false end if level = level - 1 xmlfile.write vbcrlf & space(intIndentation*level) & "" end sub private function quote(wert) ' 308060 HOW TO: Locate and Replace Special Characters in an XML File with Visual Basic .NET ' 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 if len (tempwert ) > 0 then tempwert=replace(tempwert ,"&","&") tempwert=replace(tempwert ,"<","<") tempwert=replace(tempwert ,">",">") tempwert=replace(tempwert ,"""",""") tempwert=replace(tempwert ,"'","'") end if quote=tempwert end function sub close() : xmlfile.Close : end sub end class class debugwriter ' Generic Class für writing debugging information private objIE, file, fs, debugfilename, status, strline private debuglevelIE , debuglevelfile, debugleveleventlog, debuglevelConsole private Sub Class_Initialize status = "active" : strline = "" : debugfilename = "" debuglevelIE = -1 debuglevelfile = -1 debugleveleventlog = -1 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 strMessage = strline & strMessage if (status = "active") Then if (debuglevelfile >= intseverity) 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)) end if if debugleveleventlog >=intSeverity 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 >=intSeverity 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 >=intSeverity 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) 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 makefilename(byVal 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 makevalidDN(byVal wert) ' Based on http://www.ietf.org/rfc/rfc2253.txt Chaper 2.4 wert = replace(wert,"\","\\") ' \ immer zuerst erseetzen !! wert = replace(wert,",","\,") ' wert = replace(wert,"+","\+") ' + wert = replace(wert,"""","\""") ' " wert = replace(wert,"<","\<") ' < wert = replace(wert,">","\>") ' > wert = replace(wert,";","\;") ' ; if left(wert,1) = " " then wert = "\" & wert ' Space at beginning if left(wert,1) = "#" then wert = "\" & wert ' # at beginning if right(wert,1) = " " then wert = left(wert,len(wert)-1) & "\ " ' Space at end makevalidDN = wert end function 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 next Convert2Text = tempwert end function Function ParseDelimitedText(ByVal CSV, ByVal Delimiter, ByVal Qualifier) ' http://cwashington.netreach.net/depo/view.asp?Index=320&ScriptType=vbscript Dim strCurrentChar, strValue, bProcessQualifier, iArrayCount, iCurrentPosition, iMode, iNumChars, iTotalLength Dim arrCSV() bProcessQualifier = False iArrayCount = 0 : iMode = 0 : iNumChars = 0 : iTotalLength = Len(CSV) Redim Preserve arrCSV(iArrayCount) For iCurrentPosition = 1 To iTotalLength strCurrentChar = Mid(CSV, iCurrentPosition, 1) If (strCurrentChar = Qualifier) And (iNumChars = 0) Then bProcessQualifier = True strCurrentChar = "" End If iNumChars = iNumChars + 1 If (bProcessQualifier = True) Then If (Len(strValue) <> 0) Then If (strCurrentChar = Delimiter) Then strValue = "" bProcessQualifier = False iMode = 2 Else strValue = "" iMode = 1 End If Else If (strCurrentChar = Qualifier) Then strValue = strValue & strCurrentChar iMode = 0 Else iMode = 1 End If End If Else If (strCurrentChar = Delimiter) Then iMode = 2 Else iMode = 1 End If End If Select Case iMode Case 1 arrCSV(iArrayCount) = arrCSV(iArrayCount) & strCurrentChar Case 2 iNumChars = 0 iArrayCount = iArrayCount + 1 Redim Preserve arrCSV(iArrayCount) End Select Next ParseDelimitedText = arrCSV 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 & "