使用带有两个电子邮件地址的vba将Outlook中的电子邮件主题复制到Excel？答案

【问题标题】：Copy email subject in outlook to excel using vba with two email address?使用带有两个电子邮件地址的vba将Outlook中的电子邮件主题复制到Excel？
【发布时间】：2016-11-01 16:21:01
【问题描述】：

我有两个电子邮件地址。第一个是address1@domain.com.vn，第二个是address2@domain.com.vn。

我想使用 vba 将第二个地址 address2@domain.com.vn 的电子邮件主题复制到 Microsoft Outlook 中。我使用波纹管代码，但它不起作用。

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

【问题讨论】：

从问题中删除了您的实际电子邮件 - 您并没有尝试在上述代码中复制您的电子邮件
这是我的错误。谢谢@dbmitch

标签： vba excel email outlook

【解决方案1】：

试试这个

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

【讨论】：

感谢您的支持。但是你的代码没有运行。错误在Set Fldr = olapp.Folders(MailboxName).Folders(Pst_Folder_Name) 行
我的代码中没有这样的行。请按照我写的完全运行它并告诉我
什么没有运行？你遇到什么错误了吗？如果是这样，什么样的错误，由哪一行抛出？
消息框：“尝试的操作失败。找不到对象”和Set Fldr = olNs.Folders(MailboxName).Folders(Pst_Folder_Name) 行中的错误（luunt1@vpb.com.vn 是我的电子邮件地址）
然后在 Outlook 中找不到文件夹“luunt1@vpb.com.vn”或其子文件夹“收件箱”。如果您查看 Ourlook，您会在左侧文件夹列表的顶部找到“luunt1@vpb.com.vn”吗？它有一个子文件夹“收件箱”吗？

【解决方案2】：

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

例子

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

【讨论】：