'------------------------------------------------------------------------- ' feiertage ' ' Beschreibung ' Zentrales Eintragen von Terminen in Kalendern von Anwendern ' ' Vorgehensweise ' - liest eine Liste von Terminen aus einer Textdatei ' Format siehe Outlook http://www.docoutlook.de/Umgebung/Add-on/Add-on_page.htm ' erste Zeile wird ignoriert. folgezeilen enthalten den Betreff und mit Komma getrennt das Startdatum ' [Deutschland] 2 ' Test8-12-05, 2005/12/08 ' Test9-12-05, 2005/12/09 ' - Holt alle Empfänger aus dem AD ' - Verbindet sich per CDO 1.21 mit jedem einzelnen Postfach ' - Importiert die Termine in den Kalender, wenn noch nicht vorhanden ' - Ausgabe der Aktionen als XML ' ' Voraussetzung ' - Ausführender Benutzer muss auf alle Postfächer Vollzugriff haben ' - Verbindung zum DC/GC und Mailserver ' - CDO 1.21 ' ' Version 1.0 (07. Dez 2005) ' Erste Version ' Umfangreiche Tests sind noch ausstehen ' Version 1.1 (08. Dez 2005) ' TerminKalender des Postfach cachen, verbesserte Abarbeitung ' Korrektur Berechnung Restlaufzeit ' Version 1.2 (08. Dez 2005) ' Freebusy= Frei ' Categories = Feiertag ' Version 1.3 (24. Jan 2006) ' Sonderbehandlung der LDAP-Objekte mit replace \/ ' Version 1.4 (01. Feb 2006) ' Fehler mit ubound(array,2) !!! ' Version 1.5 (08. feb 2006) ' Letzter Feiertag wurde "vergessen" da ubound mit -1 eingesetzt wurde (Arrays beginnen bei 0 bis ubound ' Version 1.6 (15. Jun 2006) ' "Merker" bereits bearbeiteter Postfächer im AD setzen umd Arbeit zu sparen ' Das Script importiert aber eh nur Feiertage, die noch nicht vorhanden sind. ' Version 1.7 (13. Nov 2007) ' Fehler in FindGC Path gibt auf dem Bildschirm falsche Werte aus ' Version 1.8 (21. Dec 2007) ' oAppointment.AllDayEvent = true ' Version 1.9 (22. Sep 2008) ' MehrDebugausgaben ' Version 1.10 (14. Okt 2008) ' Prüfen und setzen der Mailbox Zeitzone ' Version 1.11 (23. Jan 2009) ' Error bei Mailbox Zeitzone abgefangen ' Location addiert ' Simulationsmode addiert ' ' Appointment Object ' http://msdn.microsoft.com/library/default.asp?URL=/library/en-us/cdo/html/aa155812-5908-4304-a855-3e9199df252a.asp ' http://www.merlyn.demon.co.uk/vb-dates.htm '------------------------------------------------------------------------- Option Explicit ' Bitte hier den Dateinamen der Importdatei angeben Const STRIMPORTFILE = ".\outlook.txt" 'Const MERKER = "extensionAttribute3" Const MERKER = "" Const conTimezone = 3 ' Zeitzone CdoTmzGMT1 Const conLocation = "Deutschland" ' Zeitzone CdoTmzGMT1 Const conSimulation = true ' Zeitzone CdoTmzGMT1 Const CdoDefaultFolderCalendar = 0 Const CdoDefaultFolderContacts = 5 Const CdoDefaultFolderDeletedItems = 4 Const CdoDefaultFolderInbox = 1 Const CdoDefaultFolderJournal = 6 Const CdoDefaultFolderNotes = 7 Const CdoDefaultFolderOutbox = 2 Const CdoDefaultFolderSentItems = 3 const CdoDefaultFolderTasks = 8 Const CdoPR_START_DATE = &H600040 Const CdoPR_END_DATE = &H610040 Const CdoPR_SUBJECT = &H0037001F dim totalerr, total, totalread, totalimport dim strOutFilePrefix dim objCommand, objConnection, objRecordSet, objUser dim ie, document, timestart, intReady dim strHomeServer, strMailbox, strMerker dim strResult dim dtStarttime dim arrFeiertage call ForceCScript ' must be rund with CSCRIPT call abbruch ("Feiertage Script fortsetzen ?" ,5) ' Last question to stop ' ----- Initialisierung der Debugging und Loggingoptionen strOutFilePrefix = "Feiertage-" & makefilename(Date() & "-" & Time()) ' Pfad und Dateiname der Log-Datei dim objDebug set objdebug = new DebugWriter objDebug.target = "file:6 console:6" ' ie eventlog objDebug.outFile = strOutFilePrefix &".log" objDebug.start objDebug.writeln "feiertage: gestartet", 0 ' Start XML-File dim xmlWriter set xmlWriter = new XmlTextWriter xmlWriter.filename = strOutFilePrefix & ".xml" xmlWriter.Indentation = 4 call xmlWriter.WriteStylesheet("feiertage.xsl") call writexslt("feiertage.xsl") call xmlWriter.WriteStartElement("feiertage") call xmlWriter.WriteElementString("starttime", now()) set ie = createobject("InternetExplorer.Application") ie.navigate("about:blank") ie.visible = true ie.document.write("Feiertage

feiertage

" & _ "" & _ "" & _ "" & _ "" & _ "" & _ "
Current Mailbox:
Current Operation:
Overall Progress:
Time: Start
Time: Running
Time: Ende
" &_ "
" & _ "
" & _ "
" & _ "
Detail:
") dtStarttime = now() ie.document.all("starttime").innerHTML = dtStarttime arrFeiertage = loadappointment(STRIMPORTFILE) ' Load Appointments into the array newlogentry "Loading List of Mailboxes from AD", 3 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 objCommand.CommandText = "<" & findGCPath & ">;" & _ "(&" & _ "(mailnickname=*)" & _ "(| " & _ "(&" & _ "(objectCategory=person)" & _ "(objectClass=User)" & _ "(|" & _ "(homeMDB=*)" & _ "(msExchHomeServerName=*)" & _ ")" & _ ")" & _ ")" & _ "(!msExchHideFromAddressLists=TRUE)" & _ ");" & _ "distinguishedName,cn,HomeMDB,mail,MailNickName;subtree" objCommand.Properties("Page Size") = 100 ' max 100 Ergebnisse auf einmal erhalten Set objRecordSet = objCommand.Execute ' und los objDebug.writeln "Total Mailboxes to check:" & objrecordset.recordcount, 0 newlogentry "Loading List of Mailboxes from AD DONE: Total:" & objrecordset.recordcount, 3 call xmlWriter.WriteElementString("totalfound", objrecordset.recordcount) total = 0 : totalread = 0 : totalerr = 0 : totalimport = 0 Do until objRecordSet.EOF ' jeden Datensatz einzeln bearbeiten. total = total + 1 call xmlWriter.WriteStartElement("object") objDebug.writeln " Processing DN:" & objRecordSet.Fields("distinguishedName"), 0 call xmlWriter.WriteElementString("dn", objRecordSet.Fields("distinguishedName")) if merker <> "" then ' use AD Attibute to Skip already processed Users objDebug.writeln " Checking Object für merker", 5 set objUser = GetObject("LDAP://" & objRecordSet.Fields("distinguishedName")) on error resume next strmerker = objUser.get(MERKER) if err then ' Attribute not found strmerker = "" objDebug.writeln " MERKER not found - will process that object", 5 end if err.clear on error goto 0 if instr(strmerker ,"Feiertagupdate") = 1 then strResult = "Object already processed at " & strmerker strmerker = "SKIP" objDebug.writeln " Object already processed at " & strmerker, 5 end if else strmerker = "" end if if strmerker <> "SKIP" then objDebug.writeln " Start Processing User", 5 strHomeServer = gethomeserver(objRecordSet.Fields("HomeMDB")) strMailbox = objRecordSet.Fields("mail") objDebug.writeln " strHomeServer:" & strHomeServer, 6 objDebug.writeln " strMailbox :" & strMailbox , 6 if strMailbox = "" then strMailbox = objRecordSet.Fields("MailNickName") if strMailbox = "" then strResult = "ERROR Finding Mailbox Name" objDebug.writeln "ERROR Finding Mailbox Name" , 1 else ' Process Mailbox objDebug.writeln " Mailbox : " & strMailbox, 0 call xmlWriter.WriteElementString("mailbox", strMailbox) call xmlWriter.WriteElementString("homeserver", strHomeServer) strResult = OpenMailbox(strHomeServer ,strMailbox, arrFeiertage) ' ---Ok lets add that to the mailbox --- if (merker <> "") and not conSimulation then objUser.Put MERKER, "Feiertagupdate:" & NOW() & " Alt:" & strmerker objDebug.writeln " Writing MERKER:" & MERKER, 4 objUser.SetInfo call xmlWriter.WriteElementString("merker", "OK") objDebug.writeln " Writing MERKER: DONE", 4 end if intReady = round(total / (objRecordSet.recordcount) * 100, 0) ie.document.all("progress").innerHTML = _ "" & _ "" & _ "
  
" & _ "Object: " & intReady & "% "& total &" / "& objRecordSet.recordcount ie.document.all("runtime").innerHTML = formatdatetime(now() - dtstarttime ,0) ie.document.all("endtime").innerHTML = formatdatetime(dtstarttime + (100 / (intReady+1))* cdbl(now - dtstarttime)) & " Estimated" ie.document.all("mailbox").innerHTML = objRecordSet.Fields("distinguishedName") end if else call xmlWriter.WriteElementString("merker", "SKIP") end if call xmlWriter.WriteElementString("result", strResult) ' ergebnis protokollieren call xmlWriter.WriteEndElement ' of Object objRecordSet.movenext Loop ie.document.all("detail").innerHTML = "" ' Clean IE Detail Output ie.document.all("mailbox").innerHTML = "Finished" call xmlWriter.WriteElementString("total", total) objDebug.writeln "Total Mailboxes checked:" & total, 0 call xmlWriter.WriteElementString("totalread", totalread) objDebug.writeln "# inspected:" & totalread, 0 call xmlWriter.WriteElementString("totalimport", totalimport) objDebug.writeln "# Total Importiert:" & totalimport, 0 call xmlWriter.WriteElementString("totalerr", totalerr) objDebug.writeln "# Error:" & totalerr, 0 call xmlWriter.WriteElementString("endtime", now()) ie.document.all("runtime").innerHTML = formatdatetime(now() - dtstarttime ,0) ie.document.all("endtime").innerHTML = now() call xmlWriter.WriteEndElement() call xmlWriter.Close set ie = nothing wscript.quit(0) function OpenMailbox (strHomeServer,strMail,arrEntries) dim oMapiMessages, oMapiFolder, oMapiMessage, oMapiSession dim oAppointmentItems, oAppointment, intTimezone on error resume next ie.document.all("detail").innerHTML = "" ' Clean IE Detail Output newlogentry "Create MAPI Session", 3 Set oMapiSession = CreateObject("MAPI.Session") if Err.Number <> 0 Then objDebug.writeln " Error creating MAPI Session Skip Mailbox",1 OpenMailbox = "ERROR CDOObject" totalerr = totalerr + 1 Exit function End If objDebug.writeln " Logon to mailbox " & objRecordSet.Fields("mail"), 0 newlogentry "Logon to Mailbox", 3 oMapiSession.Logon "", "", False, True, 0, true, strHomeServer & vbLF & strMail if Err.Number <> 0 Then objDebug.writeln " Error MAPI Logon",1 OpenMailbox = "ERROR MapiLogon" totalerr = totalerr + 1 Exit function end if newlogentry " Getting Mailbox Timezone", 3 intTimezone = oMapiSession.GetOption("TimeZone") if Err.Number <> 0 Then objDebug.writeln " Error getting TimeZone",2 intTimezone = 0 OpenMailbox = "ERROR GetTimeZone" totalerr = totalerr + 1 Exit function end if on error goto 0 if intTimezone = 3 then objDebug.writeln " Current Mailbox Timezone:" & intTimezone,5 else objDebug.writeln " updating Timzone OLD:" & intTimezone,5 if not conSimulation then oMapiSession.SetOption "TimeZone", conTimezone end if end if newlogentry " Get Calendar folder", 3 Set oMapiFolder = oMapiSession.GetDefaultFolder(CdoDefaultFolderCalendar) ' http://support.microsoft.com/kb/q180696/ if Err.Number <> 0 Then objDebug.writeln " Error MAPI Get Calendar Folder",1 OpenMailbox = "ERROR MapiGetCalendarFolder" totalerr = totalerr + 1 Exit function end if on error goto 0 objDebug.writeln "Calendar successful opened",0 newlogentry "Calendar successful opened", 3 if not conSimulation then OpenMailbox = importappointments(oMapiFolder,arrEntries) end if totalread = totalread + 1 objDebug.writeln "Cleanup:Logoff from Mailbox ", 0 newlogentry "Cleanup:Logoff from Mailbox ", 3 oMapiSession.Logoff objDebug.writeln "Cleanup: Releasing MAPI Session", 0 newlogentry "Cleanup: Releasing MAPI Session", 3 Set oMapiSession = Nothing objDebug.writeln "Cleanup:MAPI-Session released", 0 newlogentry "Cleanup:MAPI-Session released", 3 end function function importappointments(ofolder,arrTermine) ' Importiert die Termine in den Ordner, wenn noch nicht vorhanden dim oAppointment, oAppointments, count, oAppointmentFilter dim oAppointmentFilterField1, oAppointmentFilterField2, oAppointmentFilterField3 dim numimport, numskip dim dictCal set dictCal = createObject("Scripting.dictionary") newlogentry "Import Appointments into Dictionary", 3 objDebug.writeln " Import Appointments", 0 Set oAppointments = ofolder.Messages ' Termine einlesen for each oAppointment in oAppointments '~ objDebug.writeln " Cal=" & oAppointment.subject & " at " & cdbl(oAppointment.starttime) ,5 '~ objDebug.writeln " New=" & arrTermine(0,count) &" at" & cdbl(cdate(arrTermine(1,count))) ,5 if not dictcal.Exists (oAppointment.subject & cdbl(oAppointment.starttime)) then dictCal.add oAppointment.subject & cdbl(oAppointment.starttime) , 1 ' Terminbetreff und Zeit sind Schlüssel. Doppelte Termine ignorieren else 'Possible duplicate Appointment call xmlWriter.WriteElementString("duplicate", oAppointment.subject & " at " & cdbl(oAppointment.starttime)) end if next objDebug.writeln " Got " & dictCal.count & " Appointments", 0 call xmlWriter.WriteElementString("totalincal", dictCal.count) numimport = 0 : numskip = 0 for count = 0 to ubound(arrTermine,2) objDebug.writeln " Checking " & arrTermine(0,count) & " at " & arrTermine(1,count),5 if dictCal.exists( arrTermine(0,count) & cdbl(cdate(arrTermine(1,count)))) then objDebug.writeln " Already existing:" & arrTermine(0,count) & " at " & arrTermine(1,count),5 newlogentry "Skip appointment:" & arrTermine(0,count) & " at " & arrTermine(1,count),4 call xmlWriter.WriteElementString("skip", arrTermine(0,count) & " at " & arrTermine(1,count)) numskip = numskip +1 else objDebug.writeln " Import appointment:" & arrTermine(0,count) & " at " & arrTermine(1,count),5 newlogentry "Import appointment:" & arrTermine(0,count) & " at " & arrTermine(1,count),4 call xmlWriter.WriteElementString("import", arrTermine(0,count) & " at " & arrTermine(1,count)) '~ ' Termin anlegen http://msdn.microsoft.com/library/en-us/cdo/html/aa155812-5908-4304-a855-3e9199df252a.asp set oAppointment = oAppointments.add oAppointment.subject = arrTermine(0,count) oAppointment.StartTime = arrTermine(1,count) '~ oAppointment.EndTime = cdate(cdbl(cdate(arrTermine(1,count)))+1) oAppointment.AllDayEvent = true oAppointment.BusyStatus = 0 'http://msdn.microsoft.com/library/default.asp?URL=/library/en-us/cdo/html/49803859-dcc7-423a-9f2a-fa2357ead7e7.asp oAppointment.Categories = array("Feiertag") 'http://msdn.microsoft.com/library/default.asp?URL=/library/en-us/cdo/html/84308137-3e82-4e2b-9db2-bab6cca8273d.asp oAppointment.reminderset = false oAppointment.Location = conLocation oAppointment.update set oAppointment = nothing numimport = numimport +1 totalimport = totalimport + 1 end if next call xmlWriter.WriteElementString("numimport", numimport) call xmlWriter.WriteElementString("numskip", numskip) newlogentry "Import Appointments DONE", 3 objDebug.writeln "Import Appointments DONE", 0 importappointments = "OK" end function function loadappointment(filename) ' Load appointments into an array const FOR_READING = 1 dim fs, file dim arrLine, importtotal, header dim arrAppointments() call xmlWriter.WriteStartElement("source") call xmlWriter.WriteElementString("filename", filename) newlogentry "Loading Appointments from File", 3 Set fs = CreateObject("Scripting.FileSystemObject") Set file = fs.OpenTextFile(filename, FOR_READING) objDebug.writeln " reading Header",5 header = file.readline() ' skip first line call xmlWriter.WriteElementString("header", header) importtotal = 0 Do until file.AtEndofLine importtotal = importtotal + 1 objDebug.writeln " Importing Entry:" & importtotal,5 newlogentry "Loading Appointments " & importtotal, 3 call xmlWriter.WriteStartElement("entry") arrLine = split (file.readline(), ",") redim preserve arrAppointments (2,importtotal-1) arrappointments(0,importtotal-1) = arrline(0) arrappointments(1,importtotal-1) = arrline(1) newlogentry "Cal: " & arrline(0) & " at " & arrline(1), 4 call xmlWriter.WriteElementString("subject", arrline(0)) call xmlWriter.WriteElementString("date", arrline(1)) call xmlWriter.WriteEndElement Loop call xmlWriter.WriteElementString("total", importtotal) file.Close call xmlWriter.WriteEndElement loadappointment = arrappointments end function function GetHomeServer(dn) ' ermittelt den WINS-Namen des HomeServers aus dem HomeMDB-Feldformat 'z.B. CN=Postfachspeicher (SRV01),CN=Erste Speichergruppe,CN=InformationStore,CN=SRV01,CN=Servers,CN=AG1,CN=Administrative Groups,CN=MSXFAQ,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=msxfaq,DC=local dim oHomeMDB, oHomeServer objDebug.writeln " GetHomeServer für : " & dn, 5 set oHomeMDB = getobject("LDAP://" & replace(dn,"/","\/")) set oHomeServer = getobject("LDAP://" & replace(oHomeMDB.get("msExchOwningServer"),"/","\/")) objDebug.writeln " GetHomeServer is : " & oHomeServer.get("name"), 5 gethomeserver = oHomeServer.get("name") end function sub newlogentry(msg, level) dim counter, s objDebug.writeln " newlogentry: " & level & " - " & msg, 6 s = "
" for counter = 1 to level s = s + "
" next s = s & msg for counter = 1 to level s = s + "
" next s = s & "
" if level = 4 then if ie.document.all("detail").innerHTML = "" then ie.document.all("detail").innerHTML = msg else ie.document.all("detail").innerHTML = ie.document.all("detail").innerHTML & "
" & msg end if end if if level <= 3 then ie.document.all("operation").innerHTML = msg end sub sub writexslt(strfilename) dim txtxsl txtxsl = _ "" & vbcrlf & _ "" & vbcrlf & _ "" & vbcrlf & _ "" & vbcrlf & _ "feiertage Status" & vbcrlf & _ "" & vbcrlf & _ "

feiertage Status

" & vbcrlf & _ "

Parameters

" & vbcrlf & _ "" & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ "
Starttime
EndTime
Importierte Termine insgesamt
Mailboxen ohne Fehler
Mailboxen mit Fehler
" & vbcrlf & _ "

Details

" & vbcrlf & _ "" & vbcrlf & _ "" & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ " " & vbcrlf & _ "" & vbcrlf & _ "
Mailbox:Homeserver:#Import#SkipErgebnis
" & 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 ========================== function findGCPath objDebug.write "Looking für GC" dim oCont, oGC, strGCPath Set oCont = GetObject("GC:") For Each oGC In oCont strGCPath = oGC.ADsPath Next objDebug.writeln "strGCPath=" & strGCPath, 5 findGCPath = strGCPath end function 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="" if isnull(wert) then quote = "" else 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 if 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 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
TimeintseverityDescription
" & now () & "Out0Err1Wrn2Inf3Dbg"&intseverity&"" & strmessage & "