Categorised Menu List

application.itemsend Event works just before the mail is being sent

How it works: 

When the user clicks on the Send Button on the outlook mail box, this code is triggered.  Respective data will be sent to database for further analysis.


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.



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




    Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    'On Error GoTo errHandler
    Dim strTo As String, strCC As String, strBCC As String, strEntryId As String, strPureNew As String
    Dim strFrom As String, strSubject As String, strUserName As String, strAttNames As String, strSentFrom As String
    Dim strMailRefNo As String, strImportance  As String
    Dim dtCrDt As Date, dtRdDt As String
    Dim rtn As Integer, i As Integer
    'Dim oPropAccessor As Outlook.PropertyAccessor

    Dim intAttachs As Integer

    Dim mMail As MailItem

        If Item.Class = olMail Then
            If Item.Subject = "" Or IsNull(Item.Subject) Or IsEmpty(Item.Subject) Then
                MsgBox "You cannot mail an item without proper subject...", vbInformation + vbOKOnly, "Mail Subject..."
                Cancel = True
                Exit Sub
                strImportance = prcImportance(Item.Sensitivity)
                strSubject = Item.Subject
                lngPos = InStr(strSubject, "mRNo")
                'If strSubject = "" Or IsNull(strSubject) Or IsEmpty(strSubject) Then
                If lngPos <= 0 Then
                    rtn = MsgBox("This mail appears like a NEW MAIL" & vbCrLf & _
                        "Do you want to create a New Mail Reference Number", vbYesNo + vbDefaultButton1 + vbQuestion, "New Mail...")
                    If rtn = vbYes Then
                        blNew = True
                        strAction = "New"
                        frmSelect.Frame1.Enabled = False
                        strMailRefNo = prcmRno
                        frmSelect.lblMailRefNo.Caption = strMailRefNo
                    ElseIf rtn = vbNo Then
                        frmSelect.Frame1.Enabled = True
                    End If
                End If
            If strAction <> "New" Then strMailRefNo = Mid(strSubject, lngPos, 18)
                strTo = Item.To
                strFrom = Environ("Username")
                strCC = Item.CC
                strBCC = Item.BCC
                If strAction = "New" Then
                    Item.Subject = strMailRefNo & ":- " & Item.Subject
                    strSubject = Item.Subject
                    strEntryId = strMailRefNo
                    dtCrDt = Item.CreationTime
                    dtRdDt = Item.ReceivedTime
                ElseIf strAction = "Closed" Then
                    strSubject = Item.Subject & " - " & UCase(strAction)
                    Item.Subject = strSubject
                    strEntryId = strRefNo
                    strSubject = Item.Subject
                    strEntryId = strRefNo
                End If
                intAttachs = Item.Attachments.Count
                For i = 1 To intAttachs
                    strAttNames = Item.Attachments.Item(i).DisplayName & ", " & strAttNames
    '            strEntryID = strMailRefNo
        End If
        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 USERID
                    'rstpostdata.Fields(3).Value = GMB UserName to extract from mapping....
                    rstPostData.Fields(4).Value = strMailRefNo
                    rstPostData.Fields(5).Value = strAction                    ' 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 = Left(strSentFrom, 50)
                    rstPostData.Fields(11).Value = intAttachs
                    rstPostData.Fields(12).Value = Left(strAttNames, 255)
                    rstPostData.Fields(13).Value = Date
                    rstPostData.Fields(14).Value = dtCrDt
    '                rstPostData.Fields(15).Value = dtRdDt
                    rstPostData.Fields(16).Value = Left(strCIBName, 20)
                    rstPostData.Fields(17).Value = Item.SentOn
                    rstPostData.Fields(18).Value = strImportance
                    rstPostData.Fields(19).Value = strIssue
                    rstPostData.Fields(20).Value = strComments
                    'rstpostdata.Fields(21).Value = Application close time
                    'rstpostdata.fields(22).value = Application open time
                    rstPostData.Fields(23).Value = Now
                .Update ' stores the new record
            End With
            MsgBox "This message is not of the type of MAIL and hence is not monitored", vbInformation + vbOKOnly, "Non Mail type..."
        End If
        Select Case Err.Number
            Case 0
            Case 91
                Cancel = True
            Case Else
                MsgBox Str(Err.Number) & " " & Err.Description, vbInformation + vbOKOnly, "on Send..."
                Exit Sub
        End Select
    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

    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