Export emails based on a standard subject line to a specific column in Excel.

[spittingfire]

Hi All,

Looking for some help with an Outlook vb code.

I have the below code that I've put together but not getting the expected results.

I get a few emails a day with the a standard subject line Stats @ 9:00 18/10/2017, Stats @11:00 18/10/2017, Stats @ 13:00 18/10/2017, Stats @ 15:00 18/10/2017, Stats @ 17:00 18/10/2017, Stats @ 19:00 18/10/2017 and Stats @ 21:00 18/10/2017.

I'm trying to export each to a specific column in an excel file that I have created.

The vb code that I have is

    
Sub ExportMessagesToExcel()
    
    Dim olkMsg As Object, _
            excApp As Object, _
            excWkb As Object, _
            excWks As Object, _
            rCount As Long, _
            intVersion As Integer
            Dim subFolderName As String
        
            
        
        MailboxName = "***@r***.com"
        Pst_Folder_Name = "Inbox"
        subFolderName = "stats"
       
        Set Folder = Outlook.Session.Folders("***@***.com").Folders("Inbox").Folders("stats")
        
    Const strPath As String = "B:\NCC\stats.xlsm" 'the path of the workbook
    On Error Resume Next
    
    
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Open(strPath)
        Set excWks = excWkb.Worksheets("Sheet1")
        excWks.Range("A1:I1000").ClearContents
        'Write Excel Column Headers
        
        rCount = excWks.Range("D" & excWks.Rows.Count).End(-4162).Row
        intRow = excWks.Range("A" & excWks.Rows.Count).End(-4162).Row
        With excWks
            excWks.Range("A" & 1).Value = "Stats @ 09:00"
            excWks.Range("B" & 1).Value = "Stats @ 11:00"
            excWks.Range("C" & 1).Value = "Stats @ 13:00"
            excWks.Range("D" & 1).Value = "Stats @ 15:00"
            excWks.Range("E" & 1).Value = "Stats @ 17:00"
            excWks.Range("F" & 1).Value = "Stats @ 19:00"
            excWks.Range("G" & 1).Value = "Stats @ 21:00"
            excWks.Range("A1:G1").Font.Name = "Arial"
             excWks.Range("A1:G1").Font.Size = 10
             excWks.Range("A1:G1").Font.Bold = True
             excWks.Range("A1:G1").Interior.ColorIndex = 44
           
        End With
        rCount = rCount + 1
        intRow = intRow + 1
        
        'Write messages to spreadsheet
        For Each olkMsg In Folder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Subject = "*Stats @ 9:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
                excWks.Range("A" & rCount) = olkMsg.Body
             ElseIf olkMsg.Subject = "*Stats @ 11:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
                excWks.Range("B" & rCount) = olkMsg.Body
            ElseIf olkMsg.Subject = "*Stats @ 13:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
                excWks.Range("C" & rCount) = olkMsg.Body
            ElseIf olkMsg.Subject = "*Stats @ 15:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
                excWks.Range("D" & rCount) = olkMsg.Body
            ElseIf olkMsg.Subject = "*Stats @ 17:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
                excWks.Range("E" & rCount) = olkMsg.Body
            ElseIf olkMsg.Subject = "*Stats @ 19:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
                excWks.Range("F" & rCount) = olkMsg.Body
            ElseIf olkMsg.Subject = "*Stats @ 21:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
                excWks.Range("G" & rCount) = olkMsg.Body
                
            End If
        Next
        Set olkMsg = Nothing
        
        excWks.UsedRange.Columns.AutoFit
        excWkb.Close True
    
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    
End Sub
 
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function
 
Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function
 
Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

The script in it's current form only exports the latest email from the folder and dumps it to the first column.
If I remove the

On Error Resume Next

then I'm hit with a Run-time error '424' Object required
I don't know what I'm doing wrong and any help would be appreciated.

[spittingfire]

No response and marking the thread as closed with no solutions found - will work on trying something else. Thanks