使用两个电子邮件地址使用vba复制Outlook中的电子邮件主题为Excel？

我有两个电子邮件地址。 第一个是[e-mail] ，第二个是[e-mail] 。

我想复制在第二个地址[e-mail]微软Outlook的电子邮件主题优秀使用VBA。 我使用波纹pipe代码，但它不工作。

 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 = "[e-mail]" 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

尝试这个

 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 = "[e-mail]" 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

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

例

 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