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

Question

I have two email address. The first is address1@domain.com.vn and the second is address2@domain.com.vn.

I want to copy email subject in microsoft outlook with second address address2@domain.com.vn 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 = "address2@domain.com.vn"
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

Removed your actual emails from question - you're not trying to copy your email in your above code — dbmitch, Nov 01 '16 at 03:57

score 1 · Accepted Answer · answered Nov 01 '16 at 07:43

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 = "address2@domain.com.vn"
    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

answered Nov 01 '16 at 07:43

user3598756

28,893
4
18
28

Thanks because of your support. But your code 've not run. The error's in line `Set Fldr = olapp.Folders(MailboxName).Folders(Pst_Folder_Name)` – Luu nguyen Nov 01 '16 at 09:41
there's no such line in my code. Please run it exactly as I wrote and let me know – user3598756 Nov 01 '16 at 09:44
what didn't run? did you meet any error? if so, what kind of error and thrown by which line? – user3598756 Nov 01 '16 at 10:11
A message box: "The attemted operation failed. An object could not be found" and the error in line `Set Fldr = olNs.Folders(MailboxName).Folders(Pst_Folder_Name)` (luunt1@vpb.com.vn is my email address) – Luu nguyen Nov 01 '16 at 10:16
then either folder "luunt1@vpb.com.vn" or its subfolder "Inbox" hasn't been found in your Outlook. If you look at your Ourlook do yo find "luunt1@vpb.com.vn" at the top of the folders list at the left? And does it have a Subfolder "Inbox"? – user3598756 Nov 01 '16 at 10:22
Oh. I found it. I were wrong between "vpb" and "vbp" You were excellent. Sorry because I were bothered you – Luu nguyen Nov 01 '16 at 10:36
Don't worry. BTW since my answer was correct and the first one you received, you may want to accept it. Thank you – user3598756 Nov 01 '16 at 10:39

score 1 · Answer 2 · answered Nov 01 '16 at 08:21

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

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

2 Answers2

Linked