Option Explicit

' Settings
Private Const setting_username = "Administrator"
Private Const setting_password = "testar"

' End settings.

Sub OnAcceptMessage(oClient, oMessage) 
   CreateDeliveryLogEntry(oMessage)
   
End Sub

Sub CreateDeliveryLogEntry(oMessage)
   Dim obDatabase
   Set obDatabase = GetDatabaseObject
   
   Dim sFrom, sFilename, sTime, sSubject, sBody
   
   sFrom = oMessage.From
   sFilename = oMessage.Filename
   sTime = GetTimestamp(obDatabase)
   sSubject = oMessage.Subject
   sBody = oMessage.Body
   
   sFrom = Mid(sFrom, 1, 255)
   sFilename = Mid(sFilename, 1, 255)
   sSubject = Mid(sSubject, 1, 255)
   
   if (Len(sBody) > 1000000) Then
      sBody = Mid(sBody, 1, 1000000)
   End If
   
   sFrom = Escape(obDatabase, sFrom)
   sFilename = Escape(obDatabase, sFilename)
   sSubject = Escape(obDatabase, sSubject)
   sBody = Escape(obDatabase, sBody)
   
   Dim sSQL
   sSQL = "insert into hm_deliverylog (deliveryfrom, deliveryfilename, deliverytime, deliverysubject, deliverybody) values ('" & sFrom & "', '" & sFilename & "', " & sTime & ", '" & sSubject & "', '" & sBody & "')"
   
   dim iID
   iID = obDatabase.ExecuteSQLWithReturn(sSQL)
   
   dim obRecipients
   set obRecipients = oMessage.Recipients
   
   dim iRecipientCount
   iRecipientCount = obRecipients.Count
   
   dim i
   for i = 0 to iRecipientCount -1
      dim sRecipientAddress
      sRecipientAddress = obrecipients.Item(i).Address
      sRecipientAddress = Escape(obDatabase, sRecipientAddress)
      
      sSQL = "insert into hm_deliverylog_recipients (deliveryid, deliveryrecipientaddress) values (" & CStr(iID) & ", '" & sRecipientAddress & "')"
      
      Call obDatabase.ExecuteSQL(sSQL)
   Next
End Sub

Function GetDatabaseObject()
   Dim obApp
   Set obApp = CreateObject("hMailServer.Application")

	Call obApp.Authenticate(setting_username, setting_password)
   
   Set GetDatabaseObject = obApp.Database
End Function

Function Escape(obDatabase, value)

   value = Replace(value, "'", "''")

   Select Case obDatabase.DatabaseType
      Case 1: ' MySQL
         value = Replace(value, "\", "\\")
      Case 3: ' PGSQL
         value = Replace(value, "\", "\\")
   End Select
   
   Escape = value
End Function

Function GetTimestamp(obDatabase)
   Select Case obDatabase.DatabaseType
      Case 1: ' MySQL
         GetTimestamp = "NOW()"
      Case 2: ' MSSQL
         GetTimestamp = "GETDATE()"
      Case 3: ' PGSQL
         GetTimestamp = "current_timestamp"
      Case 4: ' SQL CE
         GetTimestamp = "GETDATE()"
   End Select
End Function