Auto Export info of sent items Emails with specific subject to an Excel File

Attachment 26894Attachment 26895


I am trying to automate and capture the following details from the sent mail items into an excel sheet using VBA. The objective is - whenever I sent an email with a particular subject let's say " Index Coverage Request", then the following details should automatically get saved in the excel sheet . I am pretty new to vba and not sure how to extract data from email body.


- recipient email address
- sender email address
- Index Name

- sent date and time
- Email body


Code:


Public WithEvents objMails As Outlook. Items

Private Sub Application_Startup()
Set objMails = Outlook.Application.Session.GetDefaultFolder(olFoldersentitems).Items
End Sub

Private Sub objMails_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim strExcelFile As String
Dim objExcelApp As Excel.Application
Dim objExcelWorkBook As Excel.Workbook
Dim objExcelWorkSheet As Excel.Worksheet
Dim nNextEmptyRow As Integer
Dim strColumnB As String
Dim strColumnC As String
Dim strColumnD As String
Dim strColumnE As String

If Item.Class = olMail Then
Set objMail = Item
End If


strExcelFile = "E:\Email\Email Statistics.xlsx"

On Error Resume Next
Set objExcelApp = GetObject(, "Excel.Application")
If Error <> 0 Then
Set objExcelApp = CreateObject("Excel.Application")
End If
Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
Set objExcelWorkSheet = objExcelWorkBook.Sheets("Sheet1")


nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1


strColumnB = objMail.ReceipentEmailAddress
strColumnC = objMail.SenderEmailAddress
strColumnD = objMail.SentTime
strColumnE = objMail.Body



objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB
objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC
objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD
objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE

objExcelWorkSheet.Columns("A:E").AutoFit

objExcelWorkBook.Close SaveChanges:=True
End Sub




[1]: https://i.stack.imgur.com/YnEnk.png
[2]: https://i.stack.imgur.com/ddAH3.png

Extracting text data from e-mail bodies can be complicated but assuming the example is a true reflection of the message layout, then the following will extract the data you requested to the named worksheet, when you send the message. Start with a workbook with just the header row as shown in your illustration. It might be better if you created such messages from a template to ensure consistency.

Attachment 26897

Code:

---

Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 02 Jul 2020
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim wdDoc As Object
Dim oRng As Object
Dim oPara As Object, oFind As Object
Dim lngPara As Long, i As Integer
Dim sIndex As String, sEndClient As String, sRaisedBy As String
Dim olInsp As Inspector
Dim sSender As String, sRecipient As String, sDate As String
Dim sValues As String
Dim vIndex As Variant
Const strWB As String = "E:\Email\Email Statistics.xlsx"    'Must exist
Const strSheet As String = "Sheet1"

    With Item
        If TypeName(Item) = "MailItem" And .Subject = "Index Coverage Request" Then
            sDate = Format(Date, "d-MMM-yy")
            sSender = .SenderEmailAddress
            sRecipient = .Recipients.Item(1).Address
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range
            For lngPara = 3 To oRng.Paragraphs.Count
                Set oPara = oRng.Paragraphs(lngPara).Range
                oPara.End = oPara.End - 1
                If oPara.Words.Count = 1 And Len(oPara) > 1 Then
                    If sIndex = "" Then
                        sIndex = oPara.Text
                    Else
                        sIndex = sIndex & "|" & oPara.Text
                    End If
                Else
                    Set oFind = oPara.Duplicate
                    With oFind
                        .Start = .Start + InStr(1, oFind, "out for") + 7
                        .End = .Start + InStrRev(oFind, "behalf") - 5
                    End With
                    sRaisedBy = Trim(oFind.Text)
                    'MsgBox sRaisedBy
                    Set oFind = oPara.Duplicate
                    With oFind
                        .Start = .Start + InStr(1, oFind, "behalf of") + 9
                        oFind.MoveEndWhile ".", -1073741823
                        sEndClient = oFind.Text
                        '    MsgBox sEndClient
                    End With
                    Exit For
                End If
            Next lngPara
        End If
        vIndex = Split(sIndex, "|")
        For i = 0 To UBound(vIndex)
            WriteToWorksheet strWB, strSheet, sRecipient, sSender, CStr(vIndex(i)), sEndClient, sRaisedBy, sDate
        Next i
    End With
lbl_Exit:
    Set wdDoc = Nothing
    Set oRng = Nothing
    Set oFind = Nothing
    Set olInsp = Nothing
    Exit Sub
End Sub

Private Function WriteToWorksheet(strWorkbook As String, _
                                  strRange As String, _
                                  strRecipient As String, _
                                  strSender As String, _
                                  strIndex As String, _
                                  strClient As String, _
                                  strRaisedBy As String, _
                                  strDate As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
    strRange = strRange & "$]"
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                      "Data Source=" & strWorkbook & ";" & _
                      "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
    strSQL = "INSERT INTO [Sheet1$] VALUES('" & _
            strRecipient & "', '" & _
            strSender & "', '" & _
            strIndex & "','" & _
            strClient & "', '" & _
            strRaisedBy & "', '" & _
            strDate & "')"

    Set CN = CreateObject("ADODB.Connection")
    Call CN.Open(ConnectionString)
    Call CN.Execute(strSQL, , 1 Or 128)
    CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function

---

Hi Gmayor, Hope you are safe and healthy, i tried the above code by adding a module in outlook session but not sure why its not saving any data in the sheet, i tried sending a sample email to myself with subject line : Index Coverage Request". I have Microsoft office and outlook 16 object library enabled as well in the reference section.:think: i am not sure but shouldnot it be If TypeName(Item) = "SentItem instead of If TypeName(Item) = "MailItem

A Sent mail item is still a MailItem.

Use the following in the same folder to test the code

Code:

---

Sub Test()
Dim olMsg As MailItem
    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olMsg = ActiveInspector.currentItem
        Case olExplorer
            Set olMsg = Application.ActiveExplorer.Selection.Item(1)
    End Select
    Application_ItemSend olMsg, False
lbl_Exit:
    Exit Sub
End Sub

---

Did you begin with an empty sheet ("Sheet1") apart from the header row that looks like the earlier illustration?
If it didn't work, the chances are that the message is not exactly as you described and so inappropriate data is being found

Attachment 26901