Copy email subject in outlook to excel using vba with two email address?

Question

I have two email address. The first is [email protected] and the second is [email protected].

I want to copy email subject in microsoft outlook with second address [email protected] to excel using vba. I use bellow code but it do not work.

Sub GetFromInbox()
Dim olapp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim Pst_Folder_Name
Dim MailboxName
'Dim date1 As Date
Dim i As Integer
Sheets("sheet1").Visible = True
Sheets("sheet1").Select
Cells.Select
Selection.ClearContents
Cells(1, 1).Value = "Date"
Set olapp = New Outlook.Application
Set olNs = olapp.GetNamespace("MAPI")
Set Fldr = olNs.ActiveExplorer.CurrentFolder.Items
MailboxName = "[email protected]"
Pst_Folder_Name = "Inbox"
Set Fldr = Outlook.Session.Folders(MailboxName).Folders(Pst_Folder_Name)
i = 2
For Each olMail In Fldr.Items
'For Each olMail In olapp.CurrentFolder.Items
ActiveSheet.Cells(i, 1).Value = olMail.ReceivedTime
ActiveSheet.Cells(i, 3).Value = olMail.Subject
ActiveSheet.Cells(i, 4).Value = olMail.SenderName
i = i + 1

Next olMail
End Sub

Answer 1

try this

Sub GetFromInbox()
    Dim olapp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim Fldr As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    Dim Pst_Folder_Name As String, MailboxName As String
    Dim i As Long

    MailboxName = "[email protected]"
    Pst_Folder_Name = "Inbox"
    Set olapp = New Outlook.Application
    Set olNs = olapp.GetNamespace("MAPI")

    Set Fldr = olNs.Folders(MailboxName).Folders(Pst_Folder_Name)

    With Sheets("sheet1")
        .Cells.ClearContents
        .Cells(1, 1).Value = "Date"
        i = 2
        For Each olMail In Fldr.Items
            'For Each olMail In olapp.CurrentFolder.Items
            .Cells(i, 1).Value = olMail.ReceivedTime
            .Cells(i, 3).Value = olMail.Subject
            .Cells(i, 4).Value = olMail.SenderName
            i = i + 1
        Next olMail
    End With

    olapp.Quit
    Set olapp = Nothing
End Sub

Answer 2

If your using ActiveExplorer.CurrentFolder then you don't need to set your email Inbox, code should run on currently displayed folder in explorer.

Example

Option Explicit
Public Sub Example()
    Dim Folder As MAPIFolder
    Dim CurrentExplorer As Explorer
    Dim Item As Object
    Dim App As Outlook.Application
    Dim Items As Outlook.Items
    Dim LastRow As Long, i As Long
    Dim xlStarted As Boolean
    Dim Book As Workbook
    Dim Sht As Worksheet

    Set App = Outlook.Application
    Set Folder = App.ActiveExplorer.CurrentFolder
    Set Items = Folder.Items

    Set Book = ActiveWorkbook
    Set Sht = Book.Worksheets("Sheet1")

    LastRow = Sht.Range("A" & Sht.Rows.Count).End(xlUp).Row
    i = LastRow + 1

    For Each Item In Items

        If Item.Class = olMail Then

            Sht.Cells(i, 1) = Item.ReceivedTime
            Sht.Cells(i, 2) = Item.SenderName
            Sht.Cells(i, 3) = Item.Subject

            i = i + 1

            Book.Save

        End If

    Next

    Set Item = Nothing
    Set Items = Nothing
    Set Folder = Nothing
    Set App = Nothing

End Sub