Excel Macro to get Email Subject of mails received today from outlook

[atuljadhavnetafim]

Hi

i am using this code to get email subject line which received today in outlook, but it give me only 12 subject line in excel while it is more than 100 emails in today's date.
there is no restriction set in code but still not getting result more than 12.
can you please help

Sub GetSubjectLineFromOutlook()
    Dim olApp As Object ' Outlook.Application
    Dim olNamespace As Object ' Outlook.Namespace
    Dim olFolder As Object ' Outlook.MAPIFolder
    Dim olItems As Object ' Outlook.Items
    Dim olMail As Object ' Outlook.MailItem
    Dim today As Date
    Dim subject As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim row As Long
    Dim batchSize As Integer
    Dim startIndex As Integer
    
    ' Set the workbook and worksheet explicitly
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("YourSheetName") ' Replace "YourSheetName" with the actual sheet name
    
    ' Create Outlook application object
    Set olApp = CreateObject("Outlook.Application")
    
    ' Get the MAPI namespace
    Set olNamespace = olApp.GetNamespace("MAPI")
    
    ' Get the Inbox folder
    Set olFolder = olNamespace.GetDefaultFolder(6) ' 6 represents the Inbox folder
    
    ' Get today's date
    today = Date
    
    ' Start from the first row in the worksheet
    row = 1
    
    ' Set the batch size and initial start index
    batchSize = 100 ' Adjust batch size as needed
    startIndex = 1
    
    ' Loop through items in smaller batches until all items are processed
    Do
        ' Get the items in the Inbox folder for the current batch
        Set olItems = olFolder.Items
        
        ' Sort the items by ReceivedTime in ascending order
        olItems.Sort "ReceivedTime", False
        
        ' Reset the olMail object
        Set olMail = Nothing
        
        ' Loop through each email in the current batch
        For Each olMail In olItems
            ' Check if the item is a MailItem
            If olMail.Class = 43 Then ' 43 represents a MailItem
                ' Check if the email was received today
                If DateValue(olMail.ReceivedTime) = today Then
                    ' Get the subject line of the email
                    subject = olMail.subject
                    ' Store the subject line in the worksheet
                    ws.Cells(row, 1).Value = subject
                    ' Move to the next row
                    row = row + 1
                End If
            End If
            
            ' Exit the loop if the desired batch size is reached
            If row > startIndex + batchSize - 1 Then Exit For
        Next olMail
        
        ' Update the start index for the next batch
        startIndex = row
        
        ' Clean up objects
        Set olItems = Nothing
        
    Loop While Not olMail Is Nothing
    
    ' Clean up objects
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
End Sub

 

[Zaifee]

Based on the code you provided, it appears that the loop is terminating prematurely because the condition Not olMail Is Nothing is being used as the exit condition. However, in each iteration of the loop, you're checking if the desired batch size is reached using the condition If row > startIndex + batchSize - 1 Then Exit For. This means that the loop will exit as soon as the desired batch size is reached, even if there are more emails to process.

To fix this issue, you can modify the exit condition of the loop to check if all items in the current batch have been processed. Instead of using Not olMail Is Nothing, you can check if row is greater than the total number of items in the Inbox folder. Here's an updated version of the code with the modified exit condition:

Sub GetSubjectLineFromOutlook()
    Dim olApp As Object ' Outlook.Application
    Dim olNamespace As Object ' Outlook.Namespace
    Dim olFolder As Object ' Outlook.MAPIFolder
    Dim olItems As Object ' Outlook.Items
    Dim olMail As Object ' Outlook.MailItem
    Dim today As Date
    Dim subject As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim row As Long
    Dim batchSize As Integer
    Dim startIndex As Integer
    Dim totalItems As Integer
    
    ' Set the workbook and worksheet explicitly
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("YourSheetName") ' Replace "YourSheetName" with the actual sheet name
    
    ' Create Outlook application object
    Set olApp = CreateObject("Outlook.Application")
    
    ' Get the MAPI namespace
    Set olNamespace = olApp.GetNamespace("MAPI")
    
    ' Get the Inbox folder
    Set olFolder = olNamespace.GetDefaultFolder(6) ' 6 represents the Inbox folder
    
    ' Get today's date
    today = Date
    
    ' Start from the first row in the worksheet
    row = 1
    
    ' Set the batch size and initial start index
    batchSize = 100 ' Adjust batch size as needed
    startIndex = 1
    
    ' Get the total number of items in the Inbox folder
    totalItems = olFolder.Items.Count
    
    ' Loop through items in smaller batches until all items are processed
    Do
        ' Get the items in the Inbox folder for the current batch
        Set olItems = olFolder.Items
        
        ' Sort the items by ReceivedTime in ascending order
        olItems.Sort "ReceivedTime", False
        
        ' Reset the olMail object
        Set olMail = Nothing
        
        ' Loop through each email in the current batch
        For Each olMail In olItems
            ' Check if the item is a MailItem
            If olMail.Class = 43 Then ' 43 represents a MailItem
                ' Check if the email was received today
                If DateValue(olMail.ReceivedTime) = today Then
                    ' Get the subject line of the email
                    subject = olMail.Subject
                    ' Store the subject line in the worksheet
                    ws.Cells(row, 1).Value = subject
                    ' Move to the next row
                    row = row + 1
                End If
            End If
            
            ' Exit the loop if all items in the current batch have been processed
            If row > totalItems Then Exit For
            ' Exit the loop if the desired batch size is reached
            If row > startIndex + batchSize - 1 Then Exit For
        Next olMail
        
        ' Update the start index for the next batch
        startIndex = row
        
        ' Clean up objects
        Set olItems = Nothing
        
    Loop While row <= totalItems
    
    ' Clean up objects
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
End Sub

With this modification, the loop will continue until all items in the Inbox folder have been processed, ensuring that you capture all the email subject lines received today.

 

[atuljadhavnetafim]

thanks for reply, this code works but all emails from Inbox captured, i need only today's items and not entire inbox, i thin "Today" date condition missing

 

[RoryA]

You said originally that the code was only returning12 items rather than the hundreds it should, but now you're saying it's processing all of them, not just today's ones. Which is it?

 

[atuljadhavnetafim]

Yes, in my inbox there are 7000+ emails and in Today's date around 100 emails are there, old code stop working after giving me only 12 result and stop.
but the code you provided working but it get entire Inbox subject line rather only Today's date mails.

i don't need entire inbox subject line, need only subject line for which email received today.

i hope it's clear now.

 

[RoryA]

I didn't provide you any code. Your original code works just fine here, though there is no need for the Do...Loop section that I can see.

 

[atuljadhavnetafim]

I did not understand, i need solution that's why i have posted here, i am not expert in VBA.
may be original code working at your place but not in my system.
My requirement is simple, in excel column A need to paste subject line only for which email received today's date and not entire inbox.

 

[RoryA]

Then I would use something like this:

Sub GetSubjectLineFromOutlook()
    Dim olApp As Object ' Outlook.Application
    Dim olNamespace As Object ' Outlook.Namespace
    Dim olFolder As Object ' Outlook.MAPIFolder
    Dim olMail As Object ' Outlook.MailItem
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim row As Long
    
    ' Set the workbook and worksheet explicitly
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("YourSheetName") ' Replace "YourSheetName" with the actual sheet name
    
    ' Create Outlook application object
    Set olApp = CreateObject("Outlook.Application")
    
    ' Get the MAPI namespace
    Set olNamespace = olApp.GetNamespace("MAPI")
    
    ' Get the Inbox folder
    Set olFolder = olNamespace.GetDefaultFolder(6) ' 6 represents the Inbox folder
        
    ' Start from the first row in the worksheet
    row = 1
    
   ' Loop through today's emails
   For Each olMail In olFolder.Items.Restrict("[ReceivedTime]>='" & Format$(Date, "DDDDD HH:NN") & "'")
       ' Check if the item is a MailItem
       If olMail.Class = 43 Then ' 43 represents a MailItem
             ' Store the subject line in the worksheet
             ws.Cells(row, 1).Value = olMail.subject
             ' Move to the next row
             row = row + 1
       End If
       
   Next olMail
    
End Sub

 

[nguyendang]

The following VBA macro uses Folder.GetTable method with Outlook date macro, today, to filter emails received today.

Option Explicit

Public Sub GetSubjectLineFromOutlook()
    Dim BatchSize As Long, StartIndex As Long, Row As Long
    BatchSize = 100
    Row = 1
    Dim objOlApp As Object
    On Error Resume Next
    Set objOlApp = VBA.GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Set objOlApp = VBA.CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    Dim objInbox As Object
    Set objInbox = objOlApp.GetNamespace("MAPI").GetDefaultFolder(6)
    Dim strFilter As String
    strFilter = "@SQL=%today(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
    Dim objTable As Object
    Set objTable = objInbox.GetTable(strFilter)
    Const PR_SUBJECT As String = "http://schemas.microsoft.com/mapi/proptag/0x0037001F"
    With objTable
        With .Columns
            .RemoveAll
            .Add PR_SUBJECT
        End With
        If .GetRowCount > 0 Then
            Dim objSh As Excel.Worksheet
            Set objSh = Application.ActiveWorkbook.Worksheets.Item("WorksheetName")
            Dim objRow As Object
            Do Until .EndOfTable
                If StartIndex = BatchSize + 1 Then Exit Do
                Set objRow = .GetNextRow
                Dim arrValues() As Variant
                arrValues = objRow.GetValues
                objSh.Cells(Row, 1).Value = arrValues(0)
                StartIndex = StartIndex + 1
                Row = Row + 1
            Loop
        End If
    End With
End Sub

Private Function Quote(ByVal Text As String) As String
    Quote = Chr(34) & Text & Chr(34)
End Function

 

[atuljadhavnetafim]

Then I would use something like this:

Sub GetSubjectLineFromOutlook()
    Dim olApp As Object ' Outlook.Application
    Dim olNamespace As Object ' Outlook.Namespace
    Dim olFolder As Object ' Outlook.MAPIFolder
    Dim olMail As Object ' Outlook.MailItem
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim row As Long
   
    ' Set the workbook and worksheet explicitly
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("YourSheetName") ' Replace "YourSheetName" with the actual sheet name
   
    ' Create Outlook application object
    Set olApp = CreateObject("Outlook.Application")
   
    ' Get the MAPI namespace
    Set olNamespace = olApp.GetNamespace("MAPI")
   
    ' Get the Inbox folder
    Set olFolder = olNamespace.GetDefaultFolder(6) ' 6 represents the Inbox folder
       
    ' Start from the first row in the worksheet
    row = 1
   
   ' Loop through today's emails
   For Each olMail In olFolder.Items.Restrict("[ReceivedTime]>='" & Format$(Date, "DDDDD HH:NN") & "'")
       ' Check if the item is a MailItem
       If olMail.Class = 43 Then ' 43 represents a MailItem
             ' Store the subject line in the worksheet
             ws.Cells(row, 1).Value = olMail.subject
             ' Move to the next row
             row = row + 1
       End If
      
   Next olMail
   
End Sub

This is work as i need, Thanks