🚀 go-pugleaf

Użytkownik "CYSTERNA" <e.cysterna@wp.pl> napisał w wiadomości 
news:f92cd069-ee46-4ba6-8c6f-24c0b0fa7563@o30g2000vbc.googlegroups.com...
> Pisze wlasnego klienta poczty. Mam juz zaprojektowany interface
> (idealny dla mnie) i pomysł na potężny filtr antyspamowy. Kiedyś
> natknąłem się w sieci na programik VB6, który potrafił wysyłac maile
> (i chyba tez odbierać) w formacie html i z załacznikami ale teraz nie
> mogę go znaleźć. Program bedzie tylko dla mnie więc żadna komercja.
> Czy ktoś mógłby mi podrzucic linka (nie interesują mnie activeX czy
> inne DLL, tylko czysty kod) Wiem że to gdzieś jest bo pamietam jak sie
> tym bawiłem ale minęło trochę czasu i nie mogę odszukać tego.


Tutaj kod VBS, na ktorym ja sie wzoruje.. Musisz sobie tylko wysuplac samego 
emaila, bo skrypt jest przeznaczony do monitorowania dziennika zdarzen... 
Ale moze sie przyda...

Pozdrawiam
Michal



Option Explicit

'AUTO LOG ERRORS TO THE SUPPRESSION LIST VARIABLE
Const AUTO_LOG = FALSE

'SET YOUR SMTP SERVER SETTINGS BELOW
Const SMTP_SERVER = "SMTP_SERVER_NAME_OR_URL"
Const SMTP_PORT = 25
Const SMTP_CONNECTION_TIMEOUT = 10


'SET YOUR STMP EMAIL ACCOUNT SETTINGS BELOW
Const SMTP_USERNAME = "SOME_SMTP_USERNAME"
Const SMTP_PASSWORD = "SOME_SMTP_PASSWORD"
Const SMTP_EMAIL_FROM = "DISPLAY_EMAIL_FROM <SOME_EMAIL_FROM_ADDRESS>"

'SET YOUR EMAIL OPTIONS BELOW
Const EMAIL_TO = "SOMEONE@SOMEWHERE.COMNETORGETC" '<- COMMA SEPERATED LIST 
OF RECIPIENTS
Const EMAIL_SUBJECT = "SOME_EMAIL_SUBJECT_LINE"
Const EMAIL_AS_ATTACHMENT = TRUE   '<- INFORMATION CAN BE IN THE BODY OR AS 
ATTACHMENT

'SET YOUR LOG FILE DIRECTORY
Const LOG_FILE_PATH = "C:\YOUR_LOG_FILE_PATH\"  '<- KEEP THE ENDING "\" 
OTHERWISE PROBLEMS MAY ARISE


 'ENTER OUR MAIN APPLICATION
 Check_Errors


Private Sub Check_Errors()
 'DECLARATIONS
 const TYPE_ERROR = 1
 const TYPE_WARNING = 2
 dim objWMIService, colLoggedEvents, objProps, objEvents
 dim strComputer, strHTML, strRow, strEventID, strEventTypeID, strEventType
 dim strProductName, strEventSource, strEventCategory, strEventCategoryID
 dim strUser, strSourceName, strLogFile, strMessage, strEventCode, 
strSuppress
 dim strNewSuppress, strLine, strLog, strInsertionString
 dim strDateTime
 dim blnNewErrors
 blnNewErrors = false
 'GET LIST OF PREVIOUSLY NOTIFIED ERRORS
 strSuppress = Suppresion_List
 'WE WILL BE BUILDING BOTH AN HTML FILE AND A CSV FILE
 strHTML = ""
 strLog = ""
 strHTML = "<HTML><BODY><TABLE BORDER=1 CELLPADDING=5 CELLSPACING=0 
ALIGN=CENTER>"
 strHTML = strHTML & 
"<TR><TH>LogFile</TH><TH>Type</TH><TH>Date</TH><TH>Time</TH><TH>Source</TH><TH>Category</TH><TH>Event</TH><TH>User</TH><TH>Computer</TH></TR>"
 strComputer = "."
 'CONNECT TO THE WMI SERVICE ON THIS COMPUTER
 set objWMIService = 
GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
 'GET OUR ERROR EVENTS FROM THE EVENT LOG
 set colLoggedEvents = objWMIService.ExecQuery( _
   "SELECT " & _
    "* " & _
   "FROM " & _
    "Win32_NTLogEvent " & _
   "WHERE " & _
    "EventType = '" & TYPE_ERROR & "'")
 'CYCLE THROUGH EACH ERROR EVENT
 for each objEvents in colLoggedEvents
  'GET THE PROPERTIES FOR THIS ERROR EVENT
  set objProps = objEvents.Properties_
  with objProps
   strDateTime = Convert_Time(.Item("TimeGenerated").Value)
   strLogFile = .Item("Logfile").Value
   strEventTypeID = .Item("EventType").Value
   select Case .Item("EventType").Value
    case TYPE_ERROR
     strEventType = "Error"
    case TYPE_WARNING
     strEventType = "Warning"
    case Else
     strEventType = .Item("EventType").Value
   end select
   strProductName = .Item("SourceName").Value
   strEventSource = .Item("SourceName").Value
   strEventCategoryID = .Item("Category").Value
   if isnull(.Item("CategoryString").Value) then
    strEventCategory = "None"
   else
    strEventCategory = .Item("CategoryString").Value
   end if
   if isnull(.Item("User").Value) then
    strUser = "N/A"
   else
    strUser = .Item("User").Value
   end if
   strEventID = .Item("EventIdentifier").Value
   strSourceName = .Item("SourceName").Value
   strEventCode = .Item("EventCode").Value
   strComputer = .Item("ComputerName").Value
'I REMOVED THE BELOW LINES....CAUSED THE EMAILS TO BE HUGE
'IF THIS IS NOT A PROBLEM THEN REMOVE THE COMMENTED LINES
'   if isnull(.Item("Message").Value) then
'    strMessage = ""
'    if not isnull(.Item("InsertionStrings").Value) then
'     for each strInsertionString In .Item("InsertionStrings").Value
'      strMessage = strMessage & strInsertionString & vbCrLf
'     next
'    end if
'   else
'    strMessage = .Item("Message").Value & ""
'   end if
   'START BUILDING THE OUTPUT FILES
   strRow = ""   'ROW IS FOR THE HTML FILE
   strLine = ""  'LINE IS FOR THE CSV FILE
   if instr(strSuppress, strLogFile & "," & strSourceName & "," & 
strEventCategory & "," & strEventCode & vbCrLf) = 0 Then
    'WE WILL STORE THIS LATER FOR SUPPRESSION NEXT TIME
    strNewSuppress = strNewSuppress & strLogFile & "," & strSourceName & "," 
& strEventCategory & "," & strEventCode & vbCrLf
    blnNewErrors = true
    'BUILD THE NEW HTML TABLE ROW
    strRow = "<TR><TD>"
    strRow = strRow & strLogFile
    strRow = strRow & "</TD><TD>" & strEventType
    strRow = strRow & "</TD><TD ALIGN=RIGHT>" & formatdatetime(strDateTime, 
VBShortDate)
    strRow = strRow & "</TD><TD>" & formatdatetime(strDateTime, VBLongTime)
    strRow = strRow & "</TD><TD>" & strSourceName
    strRow = strRow & "</TD><TD>" & strEventCategory
    strRow = strRow & "</TD><TD>" & strEventCode
    strRow = strRow & "</TD><TD>" & strUser
    strRow = strRow & "</TD><TD>" & strComputer
    strRow = strRow & "</TD></TR>"
'AGAIN SUPPRESSED IF YOU WANT IT....JUST UNCOMMENT THE BELOW LINE
'    strRow = strRow & "<TR><TD COLSPAN=100%>" & strMessage & "</TD></TR>"
    'BUILD THE NEW CSV LINE
    strLine = strLogFile & "," & strEventType & "," & 
formatdatetime(strDateTime, VBShortDate) & "," & _
      formatdatetime(strDateTime, VBLongTime) & "," & _
      strSourceName & "," & strEventCategory & "," & strEventCode & _
      "," & strUser & "," & strComputer & vbCrLf
   end if
  end with
  strHTML = strHTML & strRow
  strLog = strLog & strLine
 next
 strHTML = strHTML & "</TABLE></BODY></HTML>"
 Set objProps = Nothing
 Set objEvents = Nothing
 Set colLoggedEvents = Nothing
 Set objWMIService = Nothing
 Save_HTML strHTML       'SAVE THE HTML FILE...SO WE CAN ATTACH IT
 Save_DailyLog strLog      'SAVE THE DAILY CSV LOG
 strSuppress = strSuppress & strNewSuppress 'UPDATE SUPPRESSION LIST
 'WE WILL NOT SAVE THE SUPPRESSION LIST....THIS WILL BE MANUALLY ENTERED
 if AUTO_LOG = true then
  Save_Suppresion_List strSuppress   'SAVE THE SUPPRESSION LIST
 end if
 'WE ONLY SEND EMAIL IF NEW ERRORS HAVE BEEN FOUND
 if blnNewErrors = true then
  if EMAIL_AS_ATTACHMENT then
   'SEND THE EMAIL AS AN ATTACHMENT
   Send_Email True, LOG_FILE_PATH & "Attach.html"
  else
   'SEND THE EMAIL WITH THE HTML AS THE BODY
   Send_Email False, strHTML
  end if
 end if
End Sub



Private Function Convert_Time(strDateTime)
 Dim strDate, strTime
 strDate = Mid(strDateTime, 5, 2) & "/" & Mid(strDateTime, 7, 2) & "/" & 
Mid(strDateTime, 1, 4)
 strTime = Mid(strDateTime, 9, 2) & ":" & Mid(strDateTime, 11, 2) & ":" & 
Mid(strDateTime, 13, 2)
 Convert_Time = strDate & " " & strTime
End Function



Private Function Suppresion_List()
 'THIS FUNCTION RETURNS THE SUPPRESION LIST (SO WE CAN SKIP PAST ERRORS)
 dim objFileSys, objFile
 dim strSuppress, strFileName
 dim intFile
 'BUILD THE FILE PATH / NAME
 strFileName = LOG_FILE_PATH & "ERROR_LOG.TXT"
 'GET FILESYSTEM OBJECT
 Set objFileSys = CreateObject("Scripting.FileSystemObject")
 'CHECK FOR FILE EXISTANCE
 If objFileSys.FileExists(strFileName) Then
  'FILE FOUND....OPEN IT
  Set objFile = objFileSys.OpenTextFile(strFileName)
  on error resume next
  'READ THE FILE INTO A STRING
  strSuppress = objFile.ReadAll
  'CLEANUP
  objFile.Close
  set objFile = nothing
 End If
 set objFileSys = nothing
 'RETURN THE SUPPRESS LIST
 Suppresion_List = strSuppress
End Function



Private Sub Save_Suppresion_List(strSuppress)
 'SAVE THE LIST OF USED ERRORS TO A FILE (SO WE CAN SKIP THEM NEXT TIME)
 dim objFileSys, objFile
 dim strFileName
 dim intFile
 'BUILD FILE PATH / NAME
 strFileName = LOG_FILE_PATH & "ERROR_LOG.TXT"
 'GET FILESYSTEM OBJECT
 set objFileSys = CreateObject("Scripting.FileSystemObject")
 'CHECK FOR FILE EXISTANCE
 if objFileSys.FileExists(strFileName) then
  'FOUND....DELETE IT.....WE WILL MAKE A NEW ONE
  objFileSys.DeleteFile strFileName
 end if
 'WE NEED TO ADD SOMETHING TO THE BEGINNING OF THE FILE SO WE CAN USE INSTR 
FUNCTION
 if left(strSuppress, 2) <> vbCrLf then
  strSuppress = vbCrLf & strSuppress
 end if
 'OPEN THE FILE FOR WRITING
 set objFile  = objFileSys.CreateTextFile(strFileName, True)
 'WRITE THE FILE CONTENTS
 objFile.Write strSuppress
 'CLEANUP
 objFile.Close
 set objFile = nothing
 set objFileSys = nothing
End Sub



Private Sub Save_DailyLog(strLog)
 'SAVE THE DAILY CSV FILE
 const openForAppending = 8
 dim objFileSys, objFile
 dim strFileName
 dim intFile
 'BUILD FILE PATH / NAME
 strFileName = LOG_FILE_PATH & replace(formatdatetime(Date, VBShortDate), 
"/", "-") & ".csv"
 'GET FILESYSTEM OBJECT
 set objFileSys = CreateObject("Scripting.FileSystemObject")
 'CHECK FOR FILE EXISTANCE
 'OPEN THE FILE AND FORCE CREATION IF IT DOES NOT ALREADY EXIST
 Set objFile = objFileSys.OpenTextFile(strFileName, openForAppending, TRUE)
 'WRITE THE FILE CONTENTS
 objFile.Write strLog
 'CLEANUP
 objFile.Close
 set objFile = nothing
 set objFileSys = nothing
End Sub



Private Sub Save_HTML(strHTML)
 'SAVE HTML TO FILE...SO WE CAN ATTACH IT...TEMPORARY FILE
 dim objFileSys, objFile
 dim strFileName
 dim intFile
 'BUILD FILE PATH / NAME
 strFileName = LOG_FILE_PATH & "Attach.html"
 'GET FILESYSTEM OBJECT
 Set objFileSys = CreateObject("Scripting.FileSystemObject")
 'CHECK FOR FILE EXISTANCE
 If objFileSys.FileExists(strFileName) Then
  'FILE FOUND.....DELETE IT......WE ARE GOING TO MAKE A NEW ONE
  objFileSys.DeleteFile strFileName
 End If
 'OPEN FILE FOR WRITING
 Set objFile  = objFileSys.CreateTextFile(strFileName, True)
 'WRITE FILE CONTENTS
 objFile.Write strHTML
 'CLEANUP
 objFile.Close
 set objFile = nothing
 set objFileSys = nothing
End Sub



Private Function Send_Email(blnAsAttachment, strHTML)
 'SEND THE EMAIL TO RECIEPIENTS
 'SOME UGLY CONSTANT DEFINITIONS
 const cdoSendUsingPort = 2
 const cdoBasic = 1
 const cdoSendUsingMethod = 
"http://schemas.microsoft.com/cdo/configuration/sendusing"
 const cdoSMTPAuthenticate = 
"http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
 const cdoSMTPServer = 
"http://schemas.microsoft.com/cdo/configuration/smtpserver"
 const cdoSMTPServerPort = 
"http://schemas.microsoft.com/cdo/configuration/smtpserverport"
 const cdoSMTPConnectionTimeout = 
"http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
 const cdoSendUserName = 
"http://schemas.microsoft.com/cdo/configuration/sendusername"
 const cdoSendPassword = 
"http://schemas.microsoft.com/cdo/configuration/sendpassword"
 dim cdoConfig, cdoMessage
 'CREATE CDO OBJECTS
 set cdoConfig = CreateObject("CDO.Configuration")
 set cdoMessage = CreateObject("CDO.Message")
 'SET OBJECT PROPERTIES
 cdoConfig.Fields.Item(cdoSendUsingMethod) = cdoSendUsingPort
 cdoConfig.Fields.Item(cdoSMTPAuthenticate) = cdoBasic
 cdoConfig.Fields.Item(cdoSMTPServer) = SMTP_SERVER
 cdoConfig.Fields.Item(cdoSMTPServerPort) = SMTP_PORT
 cdoConfig.Fields.Item(cdoSMTPConnectionTimeout) = SMTP_CONNECTION_TIMEOUT
 cdoConfig.Fields.Item(cdoSendUserName) = SMTP_USERNAME
 cdoConfig.Fields.Item(cdoSendPassword) = SMTP_PASSWORD
 'FORCE PROPERTIES TO UPDATE
 cdoConfig.Fields.Update
 'SET THE CONFIGURATION TO THE ONE THAT WE JUST SETUP
 Set cdoMessage.Configuration = cdoConfig
 'SET GENERAL EMAIL OPTIONS
 cdoMessage.From = SMTP_EMAIL_FROM
 cdoMessage.To = EMAIL_TO
 cdoMessage.CC = ""
 cdoMessage.BCC = ""
 cdoMessage.Subject = EMAIL_SUBJECT
 'TO ATTACH OR NOT TO ATTACH....THAT IS THE QUESTION
 If blnAsAttachment Then
  cdoMessage.AddAttachment strHTML
  cdoMessage.HTMLBody = "<STRONG>Event Log File Available.<BR>See 
Attachment</STRONG>"
 Else
  cdoMessage.HTMLBody = strHTML
 End If
 'GENERIC NO HTML CLIENT MESSAGE
 cdoMessage.TextBody = "Your Email Client Does Not Support HTML"
 'SEND THE EMAIL OUT
 cdoMessage.Send
 'CLEANUP
 Set cdoMessage = Nothing
 Set cdoConfig = Nothing
End Function