Categorised Menu List

Complete Sample Code

Firstly: This code, needs minimal intermediate level programming experience in VBA or Visual Basic.

 

Secondly: Needs basic understanding of Outlook Operating model or Outlook Object Model, (page 41 - contains object mode hierarchy) which contains, the way the mails are arranged in Outlook mail box.

 

Context: 

To monitor every mail that either comes into generic mail box or goes out of it.  When we receive a mail, automatically, a mail goes to the sender that the mail is received and will be responded in said interval of time.

 

How it works: 

This code resides inside Outlook and works from within Outlook, so there is not need for any third party tools to support this code.

    SAMPLE PROJECT CODE

    MONITOR MAILS IN GROUP MAIL BOX

    Option Explicit
    Dim WithEvents fwdMsgs As Items
    'Private WithEvents oInbox As Outlook.Folder
    Public WithEvents thisMail As Outlook.MailItem

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ROYALTY DECLARATIONS ~~~~~~~~~~~~~~~~~~~~~~~
    Private WithEvents olExpl As Outlook.Explorer
    Private WithEvents oInbox As Outlook.Folder

    Dim strTargetF As String

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Public g_oNS As Outlook.NameSpace

    Dim cn As ADODB.Connection
    Dim rstPostData As ADODB.Recordset, r As Long, rstNames As ADODB.Recordset
    Dim rndNo As Long
    Dim blAutoResponse As Boolean, blShowForm As Boolean, blHighPriority As Boolean
    Dim strBody As String, strPrevBody As String, strHPBody As String, strPriority As String

    Dim blRecFound As Boolean, blForward As Boolean, blAutoRespond As Boolean
    Dim dBAction As String, dBGMBUserName As String, dBSubject As String, dBCIBName As String, dBIssue As String, _
    dbCaseIDNO As String, dBStatus As String, dBResponseTime As String, dBResponseEndtime As String, dbMailRecvdTime As Date, _
    dtMailOpenTime As Date, dtMailSendTime As Date, dtMailRecv As Date

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Sub Initialize_handler()
        'Set olExpl = Application.ActiveExplorer
        'Set thisMail = Application.ActiveInspector.CurrentItem
    End Sub

    Private Sub Application_ItemLoad(ByVal Item As Object)
        If Item.Class = olMail Then
            Set thisMail = Item
        End If
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    'On Error GoTo errHandler
    Dim strFrom As String, strSubject As String, strTo As String, strCC As String, strBCC As String
    Dim strCrDt As Date, strRdDt As Date, dtMailInTime As Date
    Dim strMailRefNo As String, strAttNames As String, tempStatus As String
    Dim intCount As Integer, i As Integer, intAttachs As Integer
    Dim intMRPos As Variant, intROpen As Variant, varOOA As Variant, varAR As Variant

    Dim arItems() As String
    arItems = Split(EntryIDCollection, ",")
    Dim mMail As MailItem
        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, "Case Id No:")
            varOOA = InStr(1, strSubject, "Out of Office:")
            varAR = InStr(1, strSubject, "Automatic reply:")

            If intMRPos = 0 Then
                strMailRefNo = prcmRno
                strSubject = mMail.Subject & " - " & strMailRefNo
                mMail.Subject = strSubject
                mMail.Save
            Else
                strMailRefNo = Mid(strSubject, intMRPos, 24)
                strSubject = mMail.Subject
            End If
       End If
       Next
    '        intROpen = InStr(1, strSubject, "CLOSE")
    '
    '        If intROpen > 0 Then
    '            mMail.Subject = mMail.Subject & " - " & "RE-OPEN"
    '            mMail.Save
    '            tempStatus = "Re-Open"
    '        End If
    '
    '        strTo = mMail.To
    '        strCC = mMail.CC
    '        strBCC = mMail.BCC
    '        strImportance = prcImportance(mMail.Importance)
    '        If varAR > 0 Then GoTo gotoUpdateDB
    '        If varOOA > 0 Then GoTo gotoUpdateDB
    '
    '        If strFrom = "Inv_hold_Intl@xyzCompany" Then GoTo gotoUpdateDB
    '        If strImportance = "High" Then
    '            strHPBody = thisMail.Body
    '            blAutoResponse = True
    '            blHighPriority = True
    '            dtMailInTime = Now
    '                'ackMsgs_ItemAdd mMail
    '                'ackPriorityHigh_ItemAdd mMail
    '            mMail.UnRead = True
    '            mMail.NoAging = True
    '        ElseIf strImportance = "Normal" Then
    '            blAutoResponse = True
    '            dtMailInTime = Now
    '
    '                strPrevBody = thisMail.Body
    '                strBody = "Dear Customer," & vbCrLf & vbNewLine & _
    '                    "Thank you for writing to us. This is an automated response to your e-mail. We will respond to you within 24hrs from now (" & Format(Now, "dd-mmm-yyyy HH:MM:SS") & "hrs)" & vbCrLf & _
    '                    "To help us serve you better, please make a note of case id number as mentioned in the subject for future correspondence." & vbCrLf & vbNewLine & _
    '                    "You can also call the Accounts Payable Help Desk at 0845 604 5541." & vbCrLf & _
    '                    "Timings: Monday - Friday from 8:30hrs to 17:00hrs UK time." & vbCrLf & vbNewLine & _
    '                    "Regards" & vbCrLf & _
    '                    "ABCNN International - Accounts Payable." & vbCrLf & vbCrLf & _
    '                    "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" & vbCrLf & _
    '                    "Please Note: Attachments/Images are deleted by the automated mailer. " & vbCrLf & _
    '                    "The following is your mail for your reference." & vbCrLf & _
    '                    "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" & vbCrLf & vbNewLine & _
    '                    strPrevBody
    '
    '            'ackMsgs_ItemAdd thisMail
    '            mMail.UnRead = True
    '            mMail.NoAging = True
    '        ElseIf strImportance = "Low" Then
    '            blAutoResponse = True
    '            dtMailInTime = Now
    '
    '                strPrevBody = mMail.Body
    '                strBody = "Dear Customer," & vbCrLf & vbNewLine & _
    '                    "Thank you for writing to us. This is an automated response to your e-mail. We will respond to you within 24hrs from now (" & Format(Now, "dd-mmm-yyyy HH:MM:SS") & "hrs)" & vbCrLf & _
    '                    "To help us serve you better, please make a note of case id number as mentioned in the subject for future correspondence." & vbCrLf & vbNewLine & _
    '                    "You can also call the Accounts Payable Help Desk at 0845 604 5541." & vbCrLf & _
    '                    "Timings: Monday - Friday from 8:30hrs to 17:00hrs UK time." & vbCrLf & vbNewLine & _
    '                    "Regards" & vbCrLf & _
    '                    "ABCNN International - Accounts Payable." & vbCrLf & vbCrLf & _
    '                    "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" & vbCrLf & _
    '                    "Please Note: Attachments/Images are deleted by the automated mailer. " & vbCrLf & _
    '                    "The following is your mail for your reference." & vbCrLf & _
    '                    "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" & vbCrLf & vbNewLine & _
    '                    strPrevBody
    '
    '            'ackMsgs_ItemAdd thisMail
    '            mMail.UnRead = True
    '            mMail.NoAging = True
    '        End If
    '    End If
    '    Next
    'gotoUpdateDB:
    'prcGetUserDetails
    '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 = strOHRID   'should be replaced with ABCNN ID
    '                rstPostData.Fields(3).Value = Left(strUserName, 50)
    '                rstPostData.Fields(4).Value = strMailRefNo
    '                rstPostData.Fields(5).Value = "New_In"                    ' 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(strOHRID & " " & strUserName, 50)
    '                rstPostData.Fields(11).Value = intAttachs
    '                rstPostData.Fields(12).Value = Left(strAttNames, 255)
    '                rstPostData.Fields(13).Value = Date
    '                rstPostData.Fields(14).Value = Format(mMail.CreationTime, "dd/mmm/yyyy hh:mm:ss")      'Format(dtMailInTime, "dd/mmm/yyyy hh:mm:ss")
    '                rstPostData.Fields(15).Value = Format(mMail.ReceivedTime, "dd/mmm/yyyy hh:mm:ss")      'Format(dtMailInTime, "dd/mmm/yyyy hh:mm:ss")
    '                rstPostData.Fields(17).Value = strImportance
    '                'rstPostData.Fields(22).Value = Format(dtMailInTime, "dd/mmm/yyyy hh:mm:ss")  'deals with transaction time
    '                rstPostData.Fields(23).Value = tempStatus
    '            .Update ' stores the new record
    '        End With
    '
    'errHandler:
    '    Select Case Err.Number
    '        Case 0
    '        Case 13
    '        Case Is < 0
    '            GoTo EndPrc
    '        Case Else
    '            MsgBox Str(Err.Number) & " " & Err.Description, vbInformation + vbOKOnly, "New Mail..."
    '            Exit Sub
    'EndPrc:
    '    End Select
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub Application_Quit()
        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ update database on close
        Set rstPostData = Nothing
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub openRecSet()
    Dim strDBPath As String
        strDBPath = "D:\Users\70101010\GroupMailBox.mdb"    '~~~~~~~~~~~~~~ connect to the Access database
        'strDBPath = "\\ABCNNFiler_06\5074_normal\Permanent\GMB_MailMonitor\dbABCNN.mdb"
        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 Sub Application_Startup()

    Dim myFolder As Outlook.Folder
    Dim myEntryID As String
    Dim myStoreID As String

    Set myFolder = Application.Session.Folders("LocalCopy").Folders("1Royalty")
    myEntryID = myFolder.EntryID
    myStoreID = myFolder.StoreID
    Set oInbox = Application.Session.GetFolderFromID(myEntryID, myStoreID)
    Set olExpl = Application.ActiveExplorer

        strUserName = Application.GetNamespace("MAPI").CurrentUser
        strOHRID = environ("username")
        'MsgBox "Welcoming ROYALTY ACCOUNTS Processing Team.. " & vbCrLf & vbNewLine & _
                "            " & strUserName & " " & strOHRID, vbOKOnly + vbExclamation, "McGraw-Hill Education..."
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub prcGetUserDetails()
        strUserName = Application.GetNamespace("MAPI").CurrentUser
        strOHRID = environ("username")
    End Sub

    Private Function prcImportance(intImp As Integer)
        Select Case intImp
            Case 0
                strImportance = "Low"
            Case 1
                strImportance = "Normal"
            Case 2
                strImportance = "High"
        End Select
        prcImportance = strImportance
    End Function

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub testMail_BeforeDelete(ByVal Item As Object, Cancel As Boolean)
        If Item.Class = olMail Then MsgBox "you are going to delete a mail..."
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub oInbox_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
        MsgBox "test for BEFORE ITEM MOVE event"
           
    Dim lngReply As Long
    Dim strMessage As String
    Dim blnDeleted As Boolean
    strMessage = "Are you sure you want to delete this item without reading it?"
    blnDeleted = False
        If Item.Class = olMail Then 'mail items only
            If (MoveTo Is Nothing) Then
                'if hard deleted the target folder is Nothing
                blnDeleted = True
            'ElseIf g_oNS.CompareEntryIDs(MoveTo.EntryID, _
                oDeletedItems.EntryID) Then
                'moved to Deleted Items folder
            blnDeleted = True
        End If
        
        If blnDeleted Then
            If Item.UnRead Then 'check UnRead status
            lngReply = MsgBox(strMessage, vbExclamation + vbYesNo)
        
                If lngReply = vbNo Then
                'cancel the deletion if user says to works for hard deletes too.
                    Cancel = True
                End If
        End If
    End If
    End If

    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub olExpl_FolderSwitch()
        'Initialize_handler
        Application_Startup
        Set olExpl = Application.ActiveExplorer
    '    MsgBox olExpl.CurrentFolder.Name
        strTargetF = olExpl.CurrentFolder.Name
        Debug.Print strTargetF
    '    Select Case olExpl.CurrentFolder.Name
    '        Case "Inbox"
    '            olExpl.CurrentView = "Messages"
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub olExpl_SelectionChange()
        MsgBox " selection changed.."
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub thisMail_Close(Cancel As Boolean)
        MsgBox "You are going to Close this mail window...........", vbInformation + vbOKOnly, "Close Window..."
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub thisMail_Open(Cancel As Boolean)

    Dim rtn As Integer, strPrevBody As String, intRtn As Integer, intMRPos As Integer
    Dim strTo As String, strCC As String, strBCC As String, strMailRefNo  As String, strMailType As String

    '~~~~~~~~~~~~~~~~~~~~~~~ new mail initiated from GMB Inbox - generally FYI Mails ~~~~~~~~~~~~~~~~
            If Len(Trim(thisMail.To)) <= 0 And Len(Trim(thisMail.CC)) <= 0 And Len(thisMail.BCC) <= 0 Then
                rtn = MsgBox("Do you want to open this mail to continue with processing ?", vbYesNo, "Open Mail...")
                If rtn = vbNo Then
                    Cancel = True
                    Exit Sub
                ElseIf rtn = vbYes Then
                    strAction = "New_Out"
                    blAutoResponse = False
                        If Left(thisMail.Subject, 2) = "FW" Then
                            strMailType = "FW"
                            intMRPos = InStr(1, thisMail.Subject, "Case Id No:")
                            If intMRPos > 0 Then
                                strMailRefNo = Mid(thisMail.Subject, intMRPos, 24)
                                prcSearchCode strMailRefNo, strMailType
                            End If
                        End If
                    'dtStartTime = Now
                    dtMailOpenTime = Now
                    Exit Sub
                End If
            End If
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

        strSubject = thisMail.Subject
        If Len(strSubject) > 0 Then
            lngPos = InStr(strSubject, "Case Id No:")
            If lngPos > 0 Then strMailRefNo = Mid(strSubject, lngPos, 24)

            prcSearchCode strMailRefNo, strMailType

            If blRecFound = True Then
                intRtn = MsgBox("This mail has ALREADY been ACTIONED TODAY, " & vbCrLf & "given below are the details of latest repsonse... " & vbCrLf & vbNewLine & _
                    "Previous mail details :" & vbCrLf & _
                    "    GMB User Name" & vbTab & ": " & dBGMBUserName & vbCrLf & _
                    "    Subject" & vbTab & vbTab & ": " & dBSubject & vbCrLf & _
                    "    CIB Name" & vbTab & ": " & dBCIBName & vbCrLf & _
                    "    Issue" & vbTab & vbTab & ": " & dBIssue & vbCrLf & _
                    "    Responsed at" & vbTab & ": " & dBResponseEndtime & vbCrLf & vbNewLine & _
                    "Do you still want to respond to this mail...", vbQuestion + vbYesNo + vbDefaultButton2, "already Responded...")
                    
                If intRtn = vbNo Then
    '                thisMail.UnRead = True
    '                thisMail.NoAging = True
                    Cancel = True
                    Exit Sub
                Else
                    blAutoResponse = False
                    'dtStartTime = Now
                    dtMailOpenTime = Now
                End If
            Else
                rtn = MsgBox("This mail is not yet actioned, " & vbCrLf & "Do you want to OPEN this mail to action...?", vbQuestion + vbYesNo + vbDefaultButton2, "Open Mail...")
                If rtn = vbYes Then
                    blAutoResponse = False
                    'dtStartTime = Now
                    dtMailOpenTime = Now
                Else
                    thisMail.UnRead = True
                    thisMail.NoAging = True
                    Cancel = True
                    Exit Sub
                End If
            End If
        End If
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub prcSearchCode(strCode As String, mType As String)
    Dim dtWDate As Date
    Dim strDBPath As String, sqlStr As String, sqlStrFW As String
    Dim rstSearchCode As ADODB.Recordset
    Dim intRecCount As Integer
    dtWDate = Date

        strDBPath = "D:\Users\70101010\GroupMailBox.mdb"    '~~~~~~~~~~~~~~ connect to the Access database
        'strDBPath = "\\ABCNNFiler_06\5074_normal\Permanent\GMB_MailMonitor\dbABCNN.mdb"
        Set cn = New ADODB.Connection
        cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source = " & strDBPath & ";"         '~~~~~~~~~~~~~ open
        Set rstSearchCode = New ADODB.Recordset
        
        'sqlStr = "Select * from tblWorkData where CaseIDNo = '" & strCode & "'"
        '----------------- 0 --------- 1 ------- 2 ------ 3 ------ 4 ----- 5 ----- 6 --------- 7 ------------- 8 ----------------
        sqlStr = "Select CaseIdNo, GMBUserName, Action, Subject, CIBName, Issue, Status, ResponseEndtime, TransTime from " & _
                    "tblWorkData where wdate = #" & dtWDate & "# and     CaseIdNo = '" & strCode & "' and " & _
                    "(Action = 'Reply' or Action = 'Forward') order by ResponseEndtime asc;"
                    
        sqlStrFW = "Select CaseIdNo, GMBUserName, Action, wdate from tblWorkData where CaseIdNo = '" & strCode & "' order by ResponseEndtime asc;"
                    
        If rstSearchCode.State = adStateClosed Then
            If mType = "FW" Then
                rstSearchCode.Open sqlStrFW, cn, adOpenKeyset, adLockOptimistic
                intRecCount = rstSearchCode.RecordCount
                If intRecCount > 0 Then
                    rstSearchCode.MoveLast
                    dtMailRecv = rstSearchCode.Fields(3)
                    Exit Sub
                End If
            Else
                rstSearchCode.Open sqlStr, cn, adOpenKeyset, adLockOptimistic
            End If
            
            intRecCount = rstSearchCode.RecordCount
            If intRecCount <= 0 Then
                blRecFound = False
            ElseIf intRecCount > 0 Then
                blRecFound = True
                rstSearchCode.MoveLast
                    dBAction = rstSearchCode.Fields(2)
                    dBGMBUserName = rstSearchCode.Fields(1).Value
                    dbCaseIDNO = rstSearchCode.Fields(0).Value
                    dBSubject = rstSearchCode.Fields(3).Value
                    dBCIBName = rstSearchCode.Fields(4).Value
                    dBIssue = rstSearchCode.Fields(5).Value
                    dBStatus = rstSearchCode.Fields(6).Value
                    dBResponseEndtime = nz(rstSearchCode.Fields(7).Value, "")
                    dBResponseTime = nz(rstSearchCode.Fields(8).Value, "")
            End If
        End If
        Set rstSearchCode = Nothing
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Sub ackMsgs_ItemAdd(ByVal Item As Object)
    On Error GoTo errHandler
    Dim strLocalError As String
    Dim intPos As Integer
         'when a new item is added to our "watched folder" we can process it
        Dim msg As MailItem
        blAutoRespond = True
        Set msg = Item.Reply
        'blAutoResponse = False
        With msg
            .Subject = "RE: " & Item.Subject
            .BodyFormat = olFormatHTML
            .Body = strBody
             If blAutoResponse = True Then blShowForm = False
            .Send
            blAutoRespond = False
            'strOldCaseID = Mid(strSubject, lngPos, 24)
            'blAutoResponse = False
        End With

    errHandler:
        strLocalError = Err.Number & " " & Err.Description
        Select Case Err.Number
            Case 0
            Case Else
                intPos = InStr(1, strLocalError, "-2147253567 (80020009)")
                If intPos > 0 Then
                    MsgBox "Sender address is not in the TO list, Please Check if it should be draft without TO address" & vbCrLf & _
                        "Please contact Admin for further assistance", vbOKOnly, "AutoResponse..."
                End If
        End Select
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Sub ackPriorityHigh_ItemAdd(ByVal Item As Object)
    On Error GoTo errHandler
    Dim strLocalError As String
    Dim intPos As Integer
         'when a new item is added to our "watched folder" we can process it
        Dim msg As MailItem
        blForward = True
        Set msg = Item.Forward
        'This is where I want to check if the mail has been replied to, and skip the "with" below if it has been replied to.
        With msg
            .Recipients.Add ("Geoseph@abcCompany.com")
            '.Recipients.Add ("repath@abcCompany.com")
            '.Recipients.Add ("Raju@xyzCompany")
            .Recipients.Add ("Pharasee@xyzCompany")
            .Subject = Item.Subject & " *** HIGH PRIORITY MAIL *** "
            .Importance = olImportanceNormal
            '.Body = strHPBody
            .Send
            blForward = False
        End With

    errHandler:
        strLocalError = Err.Number & " " & Err.Description
        Select Case Err.Number
            Case 0
            
            Case Else
                intPos = InStr(1, strLocalError, "-2147253567 (80020009)")
                If intPos > 0 Then
                    MsgBox "Sender address is not in the TO list, Please Check if it should be draft without TO address" & vbCrLf & _
                    "Please contact Admin for further assistance", vbOKOnly, "AutoResponse..."
                End If
        End Select
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub thisMail_Send(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, strAttNames As String, strSentFrom As String
    'Dim strMailRefNo As Variant, dtCrDt As Date, dtRdDt As String, strTotalTime As String, strTAT As String, strToday As String
    '
    'Dim rtn As Integer, i As Integer, intAttachs As Integer
    'Dim blNew As Boolean
    '
    'Dim mMail As MailItem
    '    If thisMail.Class = olMail Then
    '        If thisMail.Subject = "" Or IsNull(thisMail.Subject) Or IsEmpty(thisMail.Subject) Then
    '            MsgBox "You cannot mail an item without proper subject...", vbInformation + vbOKOnly, "Mail Subject..."
    '            Cancel = True
    '            Exit Sub
    '        Else
    '            'strImportance = prcImportance(thisMail.Sensitivity)
    '            strSubject = thisMail.Subject
    '            lngPos = InStr(strSubject, "Case Id No:")
    '            If lngPos <= 0 Then blNew = True
    '                If blNew = True Then
    '                    strAction = "New_Out"
    '                    blAutoResponse = False
    '                    'dtStartTime = Now
    '                    strImportance = prcImportance(thisMail.Sensitivity)
    '                    frmSelect.Frame1.Enabled = False
    '                    strMailRefNo = prcmRno
    '                    frmSelect.lblMailRefNo.Caption = strMailRefNo
    '                ElseIf Left(strSubject, 2) = "FW" Then
    '                    strAction = "Forward"
    '                    blAutoResponse = False
    '                    'dtStartTime = Now
    '                    dtMailSendTime = Now
    '                    frmSelect.optForward.Value = True
    '                    frmSelect.Frame1.Enabled = False
    '                    strMailRefNo = prcmRno
    '                    frmSelect.lblMailRefNo.Caption = strMailRefNo
    '                ElseIf Left(strSubject, 2) = "RE" Then
    '                    If blAutoResponse = True Then
    '                        strAction = "AutoResponse"
    '                    Else
    '                        strAction = "Reply"
    '                        blAutoResponse = False
    '                        frmSelect.optReply.Value = True
    '                        frmSelect.Frame1.Enabled = False
    '                        frmSelect.lblMailRefNo.Caption = strMailRefNo
    '                    End If
    '                    'dtStartTime = Now
    '                    dtMailSendTime = Now
    '                ElseIf rtn = vbNo Then
    '                    frmSelect.Frame1.Enabled = True
    '                End If
    '        'strMailRefNo = Mid(strSubject, lngPos, 24)
    '        'strOldCaseID = strMailRefNo
    '
    '        If blAutoResponse = True Then
    '            strAction = "AutoResponse"
    '            strStatus = ""
    '        Else
    '            If Left(strSubject, 2) = "FW" Then
    '                strAction = "Forward"
    '                GoTo lblNewOut
    '            ElseIf Left(strSubject, 2) = "RE" Then
    '                strAction = "Reply"
    '                GoTo lblNewOut
    '            End If
    '
    '            If blNew = False Then
    '                strAction = "Reply"
    '            Else
    '                strAction = "New_Out"
    '            End If
    '        End If
    '
    'lblNewOut:
    '        If strAction <> "New_Out" Then
    '            If lngPos > 0 Then strMailRefNo = Mid(strSubject, lngPos, 24)
    '        End If
    '        If strAction <> "AutoResponse" Then frmSelect.Show
    '            strTo = thisMail.To
    '            strFrom = environ("Username")
    '            strCC = thisMail.CC
    '            strBCC = thisMail.BCC
    '
    '            If strAction = "New_Out" Then
    '                thisMail.Subject = thisMail.Subject & " : " & strMailRefNo & " - " & UCase(strStatus)
    '                thisMail.Save
    '                strSubject = thisMail.Subject
    '                strEntryId = strMailRefNo
    '                dtCrDt = thisMail.CreationTime
    '                dtRdDt = thisMail.ReceivedTime
    '            ElseIf strStatus = "Close" Then
    '                thisMail.Subject = strSubject & " - " & UCase(strStatus)
    '                thisMail.Save
    '                strEntryId = strRefNo
    '            Else
    '                thisMail.Subject = strSubject & " - " & UCase(strStatus)
    '                thisMail.Save
    '                strEntryId = strRefNo
    '            End If
    '
    '            intAttachs = thisMail.Attachments.Count
    '            For i = 1 To intAttachs
    '                strAttNames = thisMail.Attachments.Item(i).DisplayName & ", " & strAttNames
    '                Next
    ''            strEntryID = strMailRefNo
    '    End If
    ''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'openRecSet
    'prcGetUserDetails
    '    If rstPostData.State = adStateClosed Then
    '        rstPostData.Open "tblWorkData", cn, adOpenKeyset, adLockOptimistic, adCmdTable
    '        'dtEndTime = Now
    '        dtMailSendTime = Now
    '        strOldCaseID = strMailRefNo
    '
    ''            If blHighPriority = True Then
    ''                strAction = "FLM_Foward"
    ''            ElseIf blAutoResponse = True Then
    ''                strAction = "AutoResponse"
    ''            End If
    '
    '        If blAutoRespond = True Then strAction = "AutoResponse"
    '        If blForward = True Then strAction = "Flm_Forward"
    '
    '        If blAutoRespond = False And blForward = False Then strTotalTime = prcTotalTime(dtMailOpenTime, dtMailSendTime)
    '        If blAutoResponse = False And blForward = False Then prcCalculateTAT strMailRefNo
    '        strTAT = prcTAT(dbMailRecvdTime, Now)
    '    End If
    '
    '        strToday = Format(Date, "dd/mm/yyyy")
    '        With rstPostData
    '            .AddNew ' create a new record
    '                rstPostData.Fields(1).Value = strFrom
    '                rstPostData.Fields(2).Value = environ("computername")   'should be replaced with ABCNN ID
    '                rstPostData.Fields(3).Value = strUserName
    '                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(strOHRID & " " & strUserName, 50)
    '                rstPostData.Fields(11).Value = intAttachs
    '                rstPostData.Fields(12).Value = Left(strAttNames, 255)
    '                rstPostData.Fields(13).Value = Format(Date, "dd/mmm/yyyy")
    '                'rstPostData.Fields(14).Value = Format(thisMail.CreationTime, "dd/mmm/yyyy hh:mm:ss")
    '                'rstPostData.Fields(15).Value = Format(thisMail.ReceivedTime, "dd/mmm/yyyy hh:mm:ss")
    '                rstPostData.Fields(16).Value = Left(strCIBName, 40)
    '                rstPostData.Fields(17).Value = strImportance
    '                rstPostData.Fields(18).Value = strIssue
    '                rstPostData.Fields(19).Value = strComments
    '                rstPostData.Fields(20).Value = Format(dtMailOpenTime, "dd/mmm/yyyy hh:mm:ss")
    '                rstPostData.Fields(21).Value = Format(dtMailSendTime, "dd/mmm/yyyy hh:mm:ss")
    '                'rstPostData.Fields(22).Value = strTotalTime
    '                rstPostData.Fields(23).Value = strStatus
    '                'rstPostData.Fields(24).Value = DateDiff("d", Now, dbMailRecvdTime) * -1
    '                rstPostData.Fields(24).Value = WorksheetFunction.NetworkDays(dtMailRecv, CDate(strToday))
    '            .Update ' stores the new record into access database
    '        End With
    ''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '    Else
    '        MsgBox "This message is not of the type of MAIL and hence is not monitored", vbInformation + vbOKOnly, "Non Mail type... from onSend"
    '    End If
    '
    'errHandler:
    '    Select Case Err.Number
    '        Case 0
    '        Case 91
    '            Cancel = True
    '        Case Else
    '            MsgBox Str(Err.Number) & " " & Err.Description, vbInformation + vbOKOnly, "from onSend..."
    '            Exit Sub
    '    End Select
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~SpecimenGetTimeCardTotal~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Public Function prcTotalTime(dtMailOpenTime As Date, dtMailSendTime As Date) As String
        Dim totalHours As Long, totalminutes As Long, totalSeconds  As Long
        Dim days As Long, hours As Long, minutes As Long, seconds As Long
        Dim interval As Variant
        
        interval = #12:00:00 AM#
        'interval = interval + rs![TimeSpace]
        interval = interval + (dtMailSendTime - dtMailOpenTime)
        totalHours = Int(CSng(interval * 24))
        totalminutes = Int(CSng(interval * 1440))
        totalSeconds = Int(CSng(interval * 86400))
        
        hours = totalHours Mod 24
        minutes = totalminutes Mod 60
        seconds = totalSeconds Mod 60
        
        prcTotalTime = totalHours & " hrs " & minutes & " mins and " & seconds & "secs"
    End Function

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    'Public Function prcTAT(dStartTime As Date, dEndTime As Date) As String
    Public Function prcTAT(time1 As Date, time2 As Date) As String
        Dim totalHours As Long, totalminutes As Long, totalSeconds  As Long
        Dim days As Long, hours As Long, minutes As Long, seconds As Long
        Dim interval As Variant

        interval = #12:00:00 AM#
        'interval = interval + rs![TimeSpace]
        interval = interval + (time2 - time1)
        totalHours = Int(CSng(interval * 24))
        'totalminutes = Int(CSng(interval * 1440))
        'totalSeconds = Int(CSng(interval * 86400))
        
        hours = totalHours Mod 24
        'minutes = totalminutes Mod 60
        'seconds = totalSeconds Mod 60
        
        prcTAT = Int(hours / 24)
    End Function

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub thisMail_BeforeDelete(ByVal Item As Object, Cancel As Boolean)
    Dim strFrom As String, strSubject As String, strTo As String, strCC As String, strBCC As String
    Dim strRefNo As String, strAttNames As String
    Dim intAttachs As Integer, i As Integer

    If thisMail.Class = olMail Then
        strFrom = thisMail.SenderName
        strSubject = thisMail.Subject
        strTo = thisMail.To
        strCC = thisMail.CC
        strBCC = thisMail.BCC
        'strMailType = thismail.SenderEmailAddress
    End If

    If Item.Class = olMail Then
        strFrom = Item.SenderName
        strSubject = Item.Subject
        strTo = Item.To
        strCC = Item.CC
        strBCC = Item.BCC
        intAttachs = Item.Attachments.Count
                
        For i = 1 To intAttachs
            strAttNames = Item.Attachments.Item(i).DisplayName & ", " & strAttNames
        Next
    End If

    If MsgBox("You are about to delete the message from " & UCase(strFrom) & vbCrLf & _
    "Do you confirm your action to DELETE...?" & vbCrLf & vbNewLine & _
    "Note that this action is monitored...", vbYesNo + vbQuestion + vbDefaultButton2, "Delete...?") = vbNo Then Cancel = True

    strRefNo = strSubject
    If InStr(strSubject, "Case Id No:") > 0 Then
        strRefNo = Mid(strSubject, InStr(strSubject, "Case Id No:"), 24)
    Else
        strRefNo = "No RefNo"
    End If

    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 ABCNN ID
                    rstPostData.Fields(4).Value = strRefNo
                    rstPostData.Fields(5).Value = "Delete"                    ' 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(11).Value = intAttachs
                    rstPostData.Fields(12).Value = Left(strAttNames, 255)
                    rstPostData.Fields(13).Value = Date
                    'rstPostData.Fields(23).Value = Now
                .Update ' stores the new record
            End With
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub prcCalculateTAT(strMailCode As Variant)

    Dim strDBPath As String, sqlStr As String
    Dim rstCalcTAT As ADODB.Recordset
    Dim intRecCount As Integer

        strDBPath = "D:\Users\70101010\GroupMailBox.mdb"    '~~~~~~~~~~~~~~ connect to the Access database
        'strDBPath = "\\ABCNNFiler_06\5074_normal\Permanent\GMB_MailMonitor\dbABCNN.mdb"
        Set cn = New ADODB.Connection
        cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source = " & strDBPath & ";"         '~~~~~~~~~~~~~ open
        Set rstCalcTAT = New ADODB.Recordset
        
        'sqlStr = "Select * from tblWorkData where CaseIDNo = '" & strCode & "'"
        '----------------- 0 --------- 1 ------- 2 ------
        sqlStr = "Select CaseIdNo, Subject, Action, ReceivedDT from tblWorkData where Action = 'New_In' and CaseIdNo = '" & strMailCode & "'" & " order by ReceivedDT desc;"
        If rstCalcTAT.State = adStateClosed Then
            rstCalcTAT.Open sqlStr, cn, adOpenKeyset, adLockOptimistic
            intRecCount = rstCalcTAT.RecordCount
            If intRecCount <= 0 Then
                blRecFound = False
            ElseIf intRecCount > 0 Then
                blRecFound = True
                rstCalcTAT.MoveLast
                    dbMailRecvdTime = rstCalcTAT.Fields(3).Value
            End If
        End If
        Set rstCalcTAT = Nothing
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~ PART OF MAIL OPEN CODE ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '
    '~~~~~~~~~~~~~~~~~~~~~~~ in response to existing mail~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ''        strNewCaseID = strMailRefNo
    ''        If strNewCaseID <> strOldCaseID Then
    ''            rtn = MsgBox("Do you want to open this mail to continue with processing ?", vbYesNo, "Open Mail...")
    ''            If rtn = vbNo Then
    ''                thisMail.UnRead = True
    ''                thisMail.NoAging = True
    ''                Cancel = True
    ''                Exit Sub
    ''            End If

    '            If blRecFound = False Then
    '                blAutoResponse = True
    '                dtStartTime = Now
    '
    '                strPrevBody = thisMail.Body
    '                strBody = "Dear Customer," & vbCrLf & vbNewLine & _
    '                    "Thank you for writing to us. This is an automated response to your e-mail. We will respond to you within 24hrs from now (" & Format(Now, "dd-mmm-yyyy HH:MM") & "hrs)" & vbCrLf & _
    '                    "To help us serve you better, please make a note of case id number as mentioned in the subject for future correspondence." & vbCrLf & vbNewLine & _
    '                    "You can also call the Accounts Payable Help Desk at 0845 604 5541." & vbCrLf & _
    '                    "Timings: Monday - Friday from 8:30hrs to 17:00hrs UK time." & vbCrLf & vbNewLine & _
    '                    "Regards" & vbCrLf & _
    '                    "ABCNN International - Accounts Payable." & vbCrLf & vbCrLf & _
    '                    "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" & vbCrLf & _
    '                    "Please Note: Attachments/Images are deleted by the automated mailer. " & vbCrLf & _
    '                    "The following is your mail for your reference." & vbCrLf & _
    '                    "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" & vbCrLf & vbNewLine & _
    '                    strPrevBody
    '
    '                ackMsgs_ItemAdd thisMail
    '            End If
    ''        Else
    ''            blAutoResponse = False
    ''        End If
    ''    Else
    '
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub myOlInspectors_FolderSwitch()
    Dim myFolder As Outlook.Folder
    Dim myEntryID As String
    Dim myStoreID As String

    Set myFolder = Application.Session.Folders("LocalCopy").Folders("1Royalty")
    myEntryID = myFolder.EntryID
    myStoreID = myFolder.StoreID
    Set oInbox = Application.Session.GetFolderFromID(myEntryID, myStoreID)

    MsgBox "for FOLDER SWITCH EVENT: " & vbCrLf & _
        oInbox.Name & " " & " Parent:" & oInbox.Parent

    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, to monitor mails.

    Outlook 2007 Object Model