Скопировать тему электронной почты в Outlook, чтобы Excel с помощью vba с двумя адресами электронной почты?

Question

У меня есть два адреса электронной почты. Первый - address1@domain.com.vn, а второй - address2@domain.com.vn.

Я хочу скопировать тему электронной почты в Microsoft Outlook со вторым адресом address2@domain.com.vn, чтобы использовать vba. Я использую следующий код, но он не работает.

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 

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 = "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 

Answer 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