是否使用带有两个电子邮件地址的vba将outlook中的电子邮件主题复制到excel？

我有两个电子邮件地址。第一个是

address1@domain.com.vn

第二个是

address2@domain.com.vn

我想在microsoft outlook中复制第二个地址为

address2@domain.com.vn

使用vba创建excel。我使用下面的代码，但它不工作

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

试试这个

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

如果您正在使用，则不需要设置电子邮件收件箱，代码应该在资源管理器中当前显示的文件夹上运行

范例

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

---

从问题中删除了您的实际电子邮件-您没有试图在上述代码中复制您的电子邮件，这是我的错误。谢谢你，谢谢你的支持。但您的代码尚未运行。错误在行

Set Fldr=olapp.Folders（MailboxName）.Folders（Pst_Folder_Name）

我的代码中没有这样的行。请完全按照我写的那样运行，让我知道什么没有运行？你遇到错误了吗？如果是，哪一行引发了什么类型的错误？一个消息框：“尝试的操作失败。找不到对象”和第

Set Fldr=olNs.Folders（MailboxName）。Folders（Pst文件夹名称）

(luunt1@vpb.com.vn是我的电子邮件地址）然后是任一文件夹“luunt1@vpb.com.vn或其子文件夹“收件箱”尚未在您的Outlook中找到。如果你看着你的脸，你会发现“luunt1@vpb.com.vn“在左侧文件夹列表的顶部？它是否有子文件夹“收件箱”？