Consulting

Results 1 to 4 of 4

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

  1. #1

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

    Capture.jpgCapture.jpg


    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

  2. #2
    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.

    sheet.jpg


    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    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. i am not sure but shouldnot it be If TypeName(Item) = "SentItem instead of If TypeName(Item) = "MailItem
    Last edited by atulsanwal22; 07-02-2020 at 10:36 PM. Reason: Missed something to mention

  4. #4
    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

    msg.jpg
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •