'------------------------------------------------------------------------- ' InboxProcessor ' ' Beschreibung ' Skript liest eine vorgegeben Mailbox und reagiert auf eingegangene Mails ' z.B . ablage der Anlage in ein Verzeichnis, Weiterleiten an andere System etc. ' ' Vorgehensweise ' - Check des Posteingang auf Mails mit bestimmten Betreff ' ' Voraussetzung ' - Ausführender Benutzer muss auf das Postfächer berechtigt sein ' - Verbindung zum DC/GC und Mailserver ' CDO 1.21 (z.B. auf dem Exchange Server) ' ' Version 1.0 (23. Jan 08) ' Erste Version basierend auf End2End-SMTPflow ' ' Erweiterungen: ' '------------------------------------------------------------------------- Option Explicit Const STRHOMESERVER = "srv01" ' any Exchange Server,. preferred to use the homeserver of the test mailbox Const STRMAILBOX = "Administrator" ' Must be your own address where the message is send from and mirror replies to Const STRSENDER = "A-Anzeigename" ' Filter für FROM-Addresses (Must be Displayname !!, Checkl CSV-File für spelling Const STRALERTMAIL = "frank.carius@netatwork.de" ' need to have the SMTP-Adress to send alerts to Const OUTCSVFILENAME = ".\InboxProcessor.csv" 'Pfad und Name der CSV-Protokolldatei" Const ATTACHMENTPATH = ".\" 'Pfad und Name der CSV-Protokolldatei" dim strOutFilePrefix, blnstop, strAlertSubject call ForceCScript ' must be rund with CSCRIPT to avoid messageboxes 'call abbruch ("InboxProcessor Script fortsetzen ?" ,5) ' Last question to stop ' ----- Initialisierung der Debugging und Loggingoptionen strOutFilePrefix = "InboxProcessor-" & makefilename(Date() & "-" & Time()) ' Pfad und Dateiname der Log-Datei dim objDebug set objdebug = new clsDebugWriter objDebug.target = "file:5 console:6" ' ie eventlog objDebug.outFile = strOutFilePrefix &".log" objDebug.start objDebug.writeln "InboxProcessor: gestartet", 0 dim outcsvfile set outcsvfile = new clsCSVWriter outcsvfile.OpenFile OUTCSVFILENAME,outcsvfile.Overwrite ' Overwrite outcsvfile.Delimiter = ";" '~ outcsvfile.Quote = "'" outcsvfile.WriteRawLine("# Inbox Processor Action Log") outcsvfile.WriteRawLine("# Created with MSXFAQ.CSVWriter") outcsvfile.AddHeader "DateTime" outcsvfile.AddHeader "Sender" outcsvfile.AddHeader "Subject" outcsvfile.AddHeader "Attachment" outcsvfile.AddHeader "Status" outcsvfile.AddHeader "Delete" outcsvfile.WriteHeader("# Field: ") objDebug.writeln "InboxProcessor: CSV File initialized", 0 if wscript.arguments.count = 0 then objDebug.writeln "InboxProcessor: Single Run", 0 call InboxProcessor elseif isnumeric(wscript.arguments(0)) then blnstop = false do objDebug.writeln "InboxProcessor: Loop every" & cint(wscript.arguments(0)) & " Seconds", 0 call InboxProcessor call abbruch ("InboxProcessor Script fortsetzen ?" ,cint(wscript.arguments(0))) ' wait time loop else objDebug.writeln "InboxProcessor: Error - Invalid Argument", 0 end if objDebug.writeln "InboxProcessor: beendet", 0 wscript.quit(0) sub InboxProcessor dim oMapiMessages, oMapiMessage, oMapiSession, objMessage, attachment dim strResult, blnSendAlert, DelMessage '~ on error resume next strResult = "Fehlermeldungen:" Set oMapiSession = CreateObject("MAPI.Session") if Err.Number <> 0 Then objDebug.writeln " Error creating MAPI Session Skip Mailbox",1 strResult = strResult & vbcrlf & "ERROR CDOObject" else objDebug.writeln " Logon to mailbox " & STRHOMESERVER & "/" & STRMAILBOX, 0 oMapiSession.Logon "", "", False, True, 0, true, STRHOMESERVER & vbLF & STRMAILBOX if Err.Number <> 0 Then objDebug.writeln " Error MAPI Logon",1 strResult = strResult & vbcrlf & "ERROR MapiLogon" else objDebug.writeln " Open Inbox", 0 Set oMapiMessages = oMapiSession.Inbox.Messages ' Posteingang öffnen if Err.Number <> 0 Then objDebug.writeln " Error MAPI Get Inbox",1 strResult = strResult & vbcrlf & "ERROR MapiGetInbox" else objDebug.writeln " Processing Inbox", 0 blnSendAlert = false For Each oMapiMessage In oMapiMessages ' Alle EMails durchgehen DelMessage = "UNKNOWN" objDebug.writeln " Processing Message -----------------------------",3 objDebug.writeln " TimeReceived:" & oMapiMessage.TimeReceived, 4 objDebug.writeln " Sender :" & oMapiMessage.Sender, 4 objDebug.writeln " Subject :" & oMapiMessage.Subject, 4 outcsvfile.StartLine outcsvfile.AddField "DateTime",oMapiMessage.TimeReceived outcsvfile.AddField "Sender",oMapiMessage.Sender outcsvfile.AddField "Subject",oMapiMessage.Subject if oMapiMessage.sender <> STRSENDER then objDebug.writeln " Wrong Sender:" & oMapiMessage.sender & " <> "& STRSENDER, 5 strAlertSubject = "Wrong Sender:" & oMapiMessage.sender & " <> "& STRSENDER strResult = strResult & vbcrlf & " Wrong Sender:" & oMapiMessage.sender & " <> "& STRSENDER outcsvfile.AddField "Attachment","-" outcsvfile.AddField "Status","WrongSender" blnSendAlert = true DelMessage = "NO" else objDebug.writeln " Right Sender:" & oMapiMessage.sender & " <> "& STRSENDER, 5 if oMapiMessage.attachments.count = 0 then objDebug.writeln " No Attachment Assume ErrorMail", 5 strAlertSubject = "No Attachment Assume ErrorMail" strResult = strResult & vbcrlf & "No Attachment Assume ErrorMail" outcsvfile.AddField "Attachment","0" outcsvfile.AddField "Status","NoAttach" blnSendAlert = true DelMessage = "NO" elseif oMapiMessage.attachments.count > 1 then objDebug.writeln " Attach: Count >1 #Anlagen:" & oMapiMessage.attachments.count, 5 strAlertSubject = "ManyAttachments ("& oMapiMessage.attachments.count &")" strResult = strResult & vbcrlf & " ALERT ManyAttachments ("& oMapiMessage.attachments.count &")" outcsvfile.AddField "Attachment",oMapiMessage.attachments.count outcsvfile.AddField "Status","ManyAttachments" blnSendAlert = true DelMessage = "NO" else for each attachment in oMapiMessage.attachments outcsvfile.AddField "Attachment",Attachment.Name objDebug.writeln " Attachment:" & Attachment.Name, 5 Attachment.WritetoFile ATTACHMENTPATH & Attachment.Name if Err.Number <> 0 Then objDebug.writeln " Error MAPI Get Inbox",1 strResult = strResult & vbcrlf & "ERROR MapiGetInbox" outcsvfile.AddField "Status","ERROR:" & Err.Number err.clear else outcsvfile.AddField "Status","SAVED" end if next end if end if if DelMessage = "YES" then objDebug.writeln " Cleanup:Delete message",2 '~ oMapiMessage.delete ' Achtung: Aktuell werden alle Mails gelöscht if Err.Number <> 0 Then objDebug.writeln " Error MAPI Delete Message",1 strResult = strResult & vbcrlf & "Error MAPI Delete Message" outcsvfile.AddField "Delete","ERROR:" & Err.Number err.clear else outcsvfile.AddField "Status","OK" end if else objDebug.writeln " Cleanup: NOT deleting message",2 outcsvfile.AddField "Delete","NO" end if outcsvfile.writeline ' CSV-Datei rausschreiben objDebug.writeln " --------------------------",2 Next ' Ab hier dann if blnSendAlert then ' Sende Alarmmeldung objDebug.writeln " ALERTMAIL: Last Status = ALERT",2 Set oMapiMessage = oMapiMessages.add oMapiMessage.Subject = "InboxProcessor-ALERT:" & strAlertSubject oMapiMessage.Text = "InboxProcessor ist fehlgeschlagen" & strResult oMapiMessage.Recipients.Add "InboxProcessor","SMTP:" & STRALERTMAIL oMapiMessage.Importance = 2 ' http://msdn.microsoft.com/library/en-us/cdo/html/5af697e2-6d98-4e4f-9d66-5d11d64c6730.asp oMapiMessage.Recipients.Resolve oMapiMessage.Update oMapiMessage.Send False ' keinen Dialog anzeigen end if set oMapiMessages = nothing end if objDebug.writeln "Logoff from Mailbox ", 0 oMapiSession.Logoff end if objDebug.writeln "Logoff complete, Releasing MAPI Session", 0 Set oMapiSession = Nothing objDebug.writeln "MAPI-Session released", 0 strResult = "OK" End If on error goto 0 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 findGCPath = oGC.ADsPath Next objDebug.writeln "strGCPath=" & strGCPath, 5 end function class clsDebugWriter ' Version 1.2 New Level rating. Corrected illegal file names ' Version 1.3 MakeFileName entfernt fuer absolute angaben ' 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 ' Debug Levels ' 0=only output ' 1=Critical ' 2=Error ' 3=Warning ' 4=information ' 5++ =verbose 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(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("Cri1") Case 2 file.Write("Err2") Case 3 file.Write("Wrn3") Case 4 file.Write("Inf4") 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 1, strMessage ' const EVENT_ERROR = 1 Case 3 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() & ",CRI1:" & strMessage Case 2 wscript.echo now() & ",ERR1:" & strMessage Case 3 wscript.echo now() & ",WRN2:" & strMessage Case 4 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 4 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 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 class clsCSVWriter ' Class to write generic CSVFiles ' Version 1.0 Initial Version ' Version 1.1 WriteHeader + Prefix, WriteRawLine ' Version 1.2 Add "Exists"-Methode und Fehler in "Append"-Methode ' Last Modified: 30. Jan 2008 ' Pending: Quotataion of '"'-Character in Data !! private csvfilename, csvfs, csvfile, chrDelimiter, chrQuote, strline private dictLine private Sub Class_Initialize chrDelimiter =";" : chrQuote = """" : csvfilename = "" set dictLine = createobject("scripting.dictionary") End Sub public property let Delimiter (wert) ' Konfigure the delimiter. Default is ";" chrDelimiter =wert end property public property let Quote(wert) ' Konfigure the sting enquoting. Default is " chrQuote = wert end property public property get Overwrite ' Contant für Filemode Overwrite = 2 end property public property get Append ' Contant für Filemode Append = 8 end property public property get Exist(strFile) Set csvfs = CreateObject("Scripting.FileSystemObject") if csvfs.FileExists(strFile) then Exist = true else Exist = False end if end property sub OpenFile(wert,intFileMode) ' Open and start a new CSV-File if csvfilename <> "" then 'Close existing debug file csvfile.close : csvfile = nothing : csvfs = nothing end if csvfilename = wert ' open debug file Set csvfs = CreateObject("Scripting.FileSystemObject") Set csvfile = csvfs.OpenTextFile(csvfilename, intFileMode, True) end sub sub AddHeader(strvalue) ' Add a new column to the csv dataset if dictLine.exists(strvalue) then objDebug.writeln "CSVWriter: duplicate Header definition:" & strValue, 1 else dictLine.add strvalue, empty end if end sub Sub WriteHeader(strPrefix) ' Write the current Header Definition to the file. optional with a prefix ' Prefix can be used to fake IISLogs with "# Field: " dim key, strline strline = "" for each key in dictLine.keys if strline <> "" then strline = strline & chrDelimiter end if strline = strline & chrQuote & cstr(key) & chrQuote next csvfile.WriteLine(strPrefix & strline) End Sub sub AddField(strfieldname,strvalue) ' add a valuue together with the field name if dictLine.exists(strfieldname) then dictLine.item(strfieldname) = strvalue else objDebug.writeln "CSVWriter: Field not declared:" & strFieldname, 1 end if end sub Sub WriteLine ' Write the current filled fields to the disk and starte a new line dim key, strline strline = "" for each key in dictLine.keys if strline <> "" then strline = strline & chrDelimiter end if strline = strline & chrQuote & dictLine(key) & chrQuote dictLine.item(key) = empty next csvfile.WriteLine(strline) End Sub Sub WriteRawLine(strLine) ' Write line without any formatting etc. Ideal für comments and other custom output csvfile.WriteLine(strline) End Sub sub StartLine ' Start a new line. Remove all existing data of the current line dim key, strline strline = "" for each key in dictLine.keys dictLine.item(key) = empty next End Sub end class
TimeintseverityDescription
" & now () & "Out0CritErr WarnInfoDbg"&intseverity&"" & strmessage & "