Count of Email by Sender from Outlook folder RRS feed

  • Question

  • Is am new to writing VBA code , I would really really appreciate if anyone can help me with a VBA macro that can do the job of counting all emails by the sender's email address , within a particular Outlook folder.

    If the count of emails from a particular sender is more than 1 , it should populate an excel sheet with data of the email adddress and the time of receipt of the mail from that sender .
    Saturday, January 10, 2015 2:30 AM

All replies

  • It is not clear whether you want to process all the messages in the folder, or just those from a particular sender. The following does the latter.

    The former would be rather more complicated if you want to record messages from senders that have sent more than one message. Recording all messages in a folder is much simpler.

    Change the folder to the location where you want to store the workbook and allow the macro to create that workbook.

    Option Explicit
    Private olNS As Outlook.NameSpace
    Private olFolder As Outlook.MAPIFolder
    Private olItems As Outlook.Items
    Private olMsg As Outlook.MailItem
    Private Count As Long
    Private strDate As String
    Private strTime As String
    Private strFrom As String
    Private strEmail As String
    Private strSubject As String
    Private strValues As String
    Private vValues As Variant
    Private ConnectionString As String
    Private strSQL As String
    Private CN As Object
    Private xlApp As Object
    Private xlWB As Object
    Private bXLStarted As Boolean
    Private nAttr As Long
    Private i As Long
    Private Const strTitles As String = "Date|Time|From|E-Mail"
    Private Const strWorkbook As String = "C:\Path\Message Log.xlsx"

    Sub MessageLog()
        Count = 0
        strFrom = InputBox("Enter sender's name to record." & vbCr & _
                           "Exact spelling is essential.")
        If strFrom = "" Then Exit Sub
        Set olNS = Outlook.GetNamespace("MAPI")
        Set olFolder = olNS.PickFolder
        Set olItems = olFolder.Items
        For Each olMsg In olItems
            'MsgBox olMsg.Sender & vbCr & strFrom
            If olMsg.Sender = strFrom Then
                Count = Count + 1
                If Count = 2 Then Exit For
            End If
        Next olMsg
        'MsgBox Count & vbCr & strFrom
        If Count > 1 Then
            MsgBox "A completion message will indicate when the process has finished."
            For Each olMsg In olItems
                If olMsg.Sender = strFrom Then
                    RecordMessage olMsg
                End If
            Next olMsg
        End If
        MsgBox "Process Complete."
        Set olNS = Nothing
        Set olFolder = Nothing
        Set olItems = Nothing
        Set olMsg = Nothing
        Exit Sub
    End Sub

    Sub RecordMessage(Item As Outlook.MailItem)
        strFrom = Item.SenderName
        strEmail = Item.SenderEmailAddress
        strDate = Format(Item.ReceivedTime, "dd/MM/yyyy")
        strTime = Format(Item.ReceivedTime, "h:mm am/pm")
        strSubject = Item.Subject
        strValues = strDate & "', '" & _
                    strTime & "', '" & _
                    strFrom & "', '" & _
        If Not FileExists(strWorkbook) = True Then xlCreateBook strWorkbook:=strWorkbook, strTitles:=strTitles
        WriteToWorksheet strWorkbook:=strWorkbook, strRange:="Sheet1", strValues:=strValues
        Exit Sub
    End Sub

    Private Function WriteToWorksheet(strWorkbook As String, _
                                      strRange As String, _
                                      strValues As String)
        ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                           "Data Source=" & strWorkbook & ";" & _
                           "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
        strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
        Set CN = CreateObject("ADODB.Connection")
        Call CN.Open(ConnectionString)
        Call CN.Execute(strSQL, , 1 Or 128)
        Set CN = Nothing
        Exit Function
    End Function

    Private Sub xlCreateBook(strWorkbook As String, strTitles As String)
        vValues = Split(strTitles, "|")
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXLStarted = True
        End If
        On Error GoTo 0
        Set xlWB = xlApp.Workbooks.Add
        With xlWB.Sheets(1)
            For i = 0 To UBound(vValues)
                .Cells(1, i + 1) = vValues(i)
            Next i
        End With
        xlWB.SaveAs strWorkbook
        xlWB.Close 1
        If bXLStarted Then
            Set xlApp = Nothing
            Set xlWB = Nothing
        End If
        Exit Sub
    End Sub

    Private Function FileExists(ByVal Filename As String) As Boolean
        On Error GoTo NoFile
        nAttr = GetAttr(Filename)
        If (nAttr And vbDirectory) <> vbDirectory Then
            FileExists = True
        End If
        Exit Function
    End Function

    Graham Mayor - Word MVP

    Monday, January 12, 2015 8:46 AM