Categorised Menu List

Application_NewMailEx Event works just before the mail is being deleted

The fact is: this code is part of a project, where, each outgoing and incoming mail is to be monitored.  This will help us understand, as to how many times a mail is being responded for the same query.

 

Context: 

Every outgoing mail is to be captured into a database without the body of the mail as it may contain customer sensitive data.

 

How it works: 

When the  A NEW MAIL ARRIVES into the outlook mail box, this code is triggered.  Respective data will be sent to database for further analysis.

    NEW MAIL EX EVENT

    WORKS WHEN A NEW MAIL IS IDENTIFIED

    Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim strFrom As String, strSubject As String, strTo As String, strCC As String, strBCC As String
    Dim strCrDt As Date, strRdDt As Date, strImportance As String

    Dim strMailRefNo As String, strAttNames As String
    Dim intCount As Integer, i As Integer, intAttachs As Integer, intMRPos As Integer

    Dim arItems() As String
    arItems = Split(EntryIDCollection, ",")
    'MsgBox " new mail..."
    Dim mMail As MailItem

        Dim nMail As Object
        Dim intInitial As Integer, intFinal As Integer, intLength As Integer
        Dim strEntryId As String

        intInitial = 1
        intLength = Len(EntryIDCollection)
        intFinal = InStr(intInitial, EntryIDCollection, ",")        '~~~~~~~~~~~~~~~~~ intstr(start, sourceString, searchString)

        For i = LBound(arItems) To UBound(arItems)
        Set mMail = Application.Session.GetItemFromID(arItems(i))
        If mMail.Class = olMail Then
            strFrom = mMail.SenderName
            strSubject = mMail.Subject
            intMRPos = InStr(1, strSubject, "mRNo")
            If intMRPos = 0 Then
                strMailRefNo = prcmRno
                strSubject = strMailRefNo & " - " & mMail.Subject
                mMail.Subject = strSubject
                mMail.Save
            Else
                strMailRefNo = Mid(strSubject, intMRPos, 18)
                strSubject = mMail.Subject
            End If

            strTo = mMail.To
            strCC = mMail.CC
            strBCC = mMail.BCC
            strImportance = prcImportance(mMail.Importance)
        End If
        Next
        
    openRecSet
        If rstPostData.State = adStateClosed Then rstPostData.Open "tblWorkData", cn, adOpenKeyset, adLockOptimistic, adCmdTable
    '    prcUpdateData rstPostData
            With rstPostData
                .AddNew ' create a new record
                    rstPostData.Fields(1).Value = strFrom
                    rstPostData.Fields(2).Value = Environ("computername")   'should be replaced with user ID
                    'rstpostdata.Fields(3).Value = GMB UserName to extract from mapping....
                    rstPostData.Fields(4).Value = strMailRefNo
                    rstPostData.Fields(5).Value = "inMail"                    ' actions such as reply, replyall, forward, close, reject, others.
                    rstPostData.Fields(6).Value = Left(strTo, 255)
                    rstPostData.Fields(7).Value = Left(strCC, 255)
                    rstPostData.Fields(8).Value = Left(strBCC, 255)
                    rstPostData.Fields(9).Value = Left(strSubject, 255)
                    'rstpostdata.Fields(10).Value = Send from ID
                    rstPostData.Fields(11).Value = intAttachs
                    rstPostData.Fields(12).Value = Left(strAttNames, 255)
                    rstPostData.Fields(13).Value = Date
                    rstPostData.Fields(14).Value = strCrDt
                    rstPostData.Fields(15).Value = strRdDt
                    rstPostData.Fields(18).Value = strImportance
                    rstPostData.Fields(23).Value = Now
                .Update ' stores the new record
            End With
    'Next
    End Sub
     

     

     

    Private Sub openRecSet()
    Dim strDBPath As String
        strDBPath = "D:\Users\DefaultUser\abcGmb.mdb"    '~~~~~~~~~~~~~~ connect to the Access database
        Set cn = New ADODB.Connection
        cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source = " & strDBPath & ";"         '~~~~~~~~~~~~~ open
        Set rstPostData = New ADODB.Recordset
    End Sub

     

     

     

    Private Function prcImportance(intImp As Integer)
    Dim strImportance As String

        Select Case intImp
            Case 0
                strImportance = "Normal"
            Case 1
                strImportance = "Personal"
            Case 2
                strImportance = "Private"
            Case 3
                strImportance = "Confidential"
        End Select
        prcImportance = strImportance
    End Function

     

     

    Issues you may encounter: While you copy and paste the code from here to code window, replace double quotes in code window again, as these quotes will appear as smart quotes.

     

    I am publishing with a pure intension to help, as the resources on Outlook are very scarce.,

    I had to try very hard to even to get very little help.,  All the code is functional at my end, and I respect every sort of disclaimer, explicitly, I dont take any responsibility what so ever.

    Most of the Outlook Code that I post here will connected to Access Database, only then, we can monitor