Thread: Capture in time and out time of email sent via outlook

The following macro will create a list in the active worksheet of emails received from the specified subfolder...

Option Explicit

Sub test()

    Dim olApp As Object
    Dim olNS As Object
    Dim olFldr As Object
    Dim olMail As Object
    Dim arrData() As Variant
    Dim Cnt As Long
    
    Set olApp = CreateObject("Outlook.Application")
    
    Set olNS = olApp.GetNamespace("MAPI")
    
'   Change the name of the subfolder accordingly
    Set olFldr = olNS.GetDefaultFolder(olFolderInbox).Folders("MySubFolder")
    
    Cnt = 0
    For Each olMail In olFldr.Items
        Cnt = Cnt + 1
        ReDim Preserve arrData(1 To 3, 1 To Cnt)
        arrData(1, Cnt) = olMail.Sender
        arrData(2, Cnt) = olMail.Subject
        arrData(3, Cnt) = olMail.ReceivedTime
    Next
    
    With ActiveSheet.Range("a1").Resize(, 3)
        .Value = Array("From", "Subject", "Received")
        .Font.Bold = True
    End With
    
    ActiveSheet.Range("a2").Resize(UBound(arrData, 2), UBound(arrData, 1)).Value = WorksheetFunction.Transpose(arrData)
    
    ActiveSheet.Range("C2", Range("C2").End(xlDown)).NumberFormat = "m/d/yyyy h:mm"
    
    ActiveSheet.Columns.AutoFit
    
End Sub

First question: As per my earlier post I said i use multiple Mailboxes so how will this Marco would would recognize which Mailbox it has to select
Second question: As mentioned in the above code you have requested to change the subfolder, since poor in coding can you elborate on this comment

GetDefaultFolder(olFolderInbox) refers to your Inbox.

Folders("MySubFolder") refers to a subfolder within your Inbox.

So, for example, if you receive your emails of interest in a subfolder within your Inbox and it's called "Project A", replace "MySubFolder" with "Project A".

Let's say that you created a personal folder and named it "2012 Emails", and that you also created a subfolder and called it "Project X". Simply replace...

Set olFldr = olNS.GetDefaultFolder(olFolderInbox).Folders("MySubFolder")

with

Set olFldr = olNS.Folders("2012 Emails).Folders("Project X")

The following macro will list in the active worksheet the name of each folder within your InBox, along with number of items for each one...

Option Explicit

Sub test()

    Dim olApp As Object
    Dim olNS As Object
    Dim olInBox As Object
    Dim olSubFolder As Object
    Dim r As Long
    
    Set olApp = CreateObject("Outlook.Application")
    
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olInBox = olNS.GetDefaultFolder(6) 'olFolderInbox
    
    Cells.ClearContents
    
    Range("a1").Resize(, 2).Value = Array("Folder", "Items")
    
    r = 2
    For Each olSubFolder In olInBox.Folders
        Cells(r, "a").Value = olSubFolder.Name
        Cells(r, "b").Value = olSubFolder.Items.Count
        r = r + 1
    Next olSubFolder
    
End Sub

Do the subfolders in your Inbox also contain subfolders? And, if so, do you want the details for those subfolders as well? Or are you only interested in the folders within your Inbox?

Place the following code in a regular module, and run the macro called 'test'...

Option Explicit

Dim arrData() As Variant
Dim Cnt As Long

Sub test()

    Dim olApp As Object
    Dim olNS As Object
    Dim olFldr As Object
    
    Set olApp = CreateObject("Outlook.Application")
    
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olFldr = olNS.GetDefaultFolder(6) 'olFolderInbox
    
    Cnt = 0
    
    Call RecursiveFolders(olFldr)
    
    Cells.ClearContents
    
    With ActiveSheet.Range("a1").Resize(, 4)
        .Value = Array("Folder", "From", "Subject", "Received")
        .Font.Bold = True
    End With
    
    ActiveSheet.Range("A2").Resize(UBound(arrData, 2), UBound(arrData, 1)).Value = WorksheetFunction.Transpose(arrData)
    
    ActiveSheet.Range("D2", Range("D2").End(xlDown)).NumberFormat = "m/d/yyyy h:mm"
    
    ActiveSheet.Columns.AutoFit
    
End Sub

Sub RecursiveFolders(olFolder As Object)

    Dim olSubFolder As Object
    Dim olMail As Object

    For Each olMail In olFolder.Items
        Cnt = Cnt + 1
        ReDim Preserve arrData(1 To 4, 1 To Cnt)
        arrData(1, Cnt) = olFolder.FolderPath
        arrData(2, Cnt) = olMail.Sender
        arrData(3, Cnt) = olMail.Subject
        arrData(4, Cnt) = olMail.ReceivedTime
    Next
    
    For Each olSubFolder In olFolder.Folders
        Call RecursiveFolders(olSubFolder)
    Next olSubFolder
    
End Sub
    

A small modification in case no mail exists in the specified folder and/or its subfolders. Replace...

    With ActiveSheet.Range("a1").Resize(, 4)
        .Value = Array("Folder", "From", "Subject", "Received")
        .Font.Bold = True
    End With
    
    ActiveSheet.Range("A2").Resize(UBound(arrData, 2), UBound(arrData, 1)).Value = WorksheetFunction.Transpose(arrData)
    
    ActiveSheet.Range("D2", Range("D2").End(xlDown)).NumberFormat = "m/d/yyyy h:mm"
    
    ActiveSheet.Columns.AutoFit

with

    If Cnt > 0 Then
    
        With ActiveSheet.Range("a1").Resize(, 4)
            .Value = Array("Folder", "From", "Subject", "Received")
            .Font.Bold = True
        End With
        
        ActiveSheet.Range("A2").Resize(UBound(arrData, 2), UBound(arrData, 1)).Value = WorksheetFunction.Transpose(arrData)
        
        ActiveSheet.Range("D2", Range("D2").End(xlDown)).NumberFormat = "m/d/yyyy h:mm"
        
        ActiveSheet.Columns.AutoFit
        
    Else
    
        MsgBox "No mail items are available...", vbExclamation
        
    End If

Sorry, the .Sender property is only available on Excel 2010. Therefore, we'll need to use the .SenderName property instead. Replace...

arrData(1, Cnt) = olMail.Sender

with

arrData(1, Cnt) = olMail.SenderName