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

[atulsanwal22]

2689426895


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

[gmayor]

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.

26897



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

[atulsanwal22]

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

[gmayor]

A Sent mail item is still a MailItem.

Use the following in the same folder to test the 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

26901