Обратитесь к почтовому ящику второй учетной записи

Question

Я пытаюсь просмотреть конкретный почтовый ящик для непрочитанных сообщений электронной почты с прикрепленными к ним файлами .pdf, а затем сохранить их в определенную папку.

Мне нужно просмотреть папку входящих сообщений определенного профиля учетной записи. Мой код работает только в том случае, если есть только одна папка «Входящие» и один профиль учетной записи.

Предположим, у меня два профиля;

Один xxxx@hotmail.com

Второй zzzz@hotmail.com

Как запустить код на Входящие второй учетной записи? (zzzz@hotmail.com)

Ниже приведен код, который у меня есть до сих пор;

Sub GetAttachments() 
On Error GoTo GetAttachments_err 

Dim ns As NameSpace 
Dim Inbox As MAPIFolder 
Dim Item As Object 
Dim Atmt As Attachment 
Dim FileName As String 
Dim varResponse As VbMsgBoxResult 

Set ns = GetNamespace("MAPI") 
Set Inbox = ns.GetDefaultFolder(olFolderInbox) 

i = 0 

' Checks inbox for messages. 
If Inbox.Items.Count = 0 Then 
MsgBox "There are no messages in your Inbox.", vbInformation, _ 
"Nothing found" 
Exit Sub 
End If 
' Checks inbox for unread messages. 
If Inbox.UnReadItemCount = 0 Then 
"Nothing found" 
Exit Sub 
End If 

' Checks for unread messages with .pdf files attached to them, if yes   then saves it to specific folder. _ 
    Puts date and time from when the mail was created infront of the filename. 
For Each Item In Inbox.Items 
For Each Atmt In Item.Attachments 
If Item.UnRead = True Then 
If Right(Atmt.FileName, 3) = "pdf" Then 
FileName = "C:\Users\XXX\Documents\Office Macro\" & _ 
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName 
Atmt.SaveAsFile FileName 
i = i + 1 
End If 
End If 
Next Atmt 
Next Item 

' Shows how many attached files there are if any are found. 
If i > 0 Then 
& vbCrLf & "Jag har sparat dem till C:\Users\XXX\Documents\Office Macro folder." _ 
& vbCrLf & vbCrLf & "Would you like to see your files?" _ 
vbQuestion + vbYesNo, "Finished!") 
If varResponse = vbYes Then 
Shell "Explorer.exe /e,C:\Users\XXX\Documents\Office Macro\", vbNormalFocus 
End If 
Else 
MsgBox "No attached files could be found.", vbInformation, _ 
"Finished!" 
End If 

GetAttachments_exit: 
    Set Atmt = Nothing 
    Set Item = Nothing 
    Set ns = Nothing 
    Exit Sub 

GetAttachments_err: 
    MsgBox "An unkown ghost spooked the program." _ 
     & vbCrLf & "Please note and report the following information." _ 
     & vbCrLf & "Macro Name: GetAttachments" _ 
     & vbCrLf & "Error Number: " & Err.Number _ 
     & vbCrLf & "Error Description: " & Err.Description _ 
     , vbCritical, "Error!" 
    Resume GetAttachments_exit 

Exit Sub 

End Sub 

После дальнейшего осмотра почтовых ящиков, которые я вижу, что есть некоторые отличия:

xxxx@hotmail.com имеет тип "IMAP/SMTP"

zzzz@hotmail.com имеет тип «Exchange ActiveSync»

Я также заметил, что идентификатор учетной записи, который мне потребуется использовать, равен 4, как показано в этом коде при отправке нового сообщения с помощью тестового макроса, указывающего, какой профиль вы хотите отправить почта от, назначая идентификатор профиля в скрипте:

Sub Mail_small_Text_Change_Account() 
'Only working in Office 2007-2013 
'Don't forget to set a reference to Outlook in the VBA editor 
    Dim OutApp As Outlook.Application 
    Dim OutMail As Outlook.MailItem 
    Dim strbody As String 

    Set OutApp = CreateObject("Outlook.Application") 
    Set OutMail = OutApp.CreateItem(olMailItem) 

    strbody = "Hi there" & vbNewLine & vbNewLine & _ 
       "This is line 1" & vbNewLine & _ 
       "This is line 2" & vbNewLine & _ 
       "This is line 3" & vbNewLine & _ 
       "This is line 4" 

    On Error Resume Next 
    With OutMail 
     .To = "blabla@blabla.nl" 
     .CC = "" 
     .BCC = "" 
     .Subject = "This is the Subject line" 
     .Body = strbody 

     'SendUsingAccount is new in Office 2007 
     'Change Item(1)to the account number that you want to use 
     .SendUsingAccount = OutApp.Session.Accounts.Item(4) <<<< ACCOUNT ID 

     .Send 'or use .Display 
    End With 
    On Error GoTo 0 

    Set OutMail = Nothing 
    Set OutApp = Nothing 
End Sub 

Answer 1

Set Входящие = ns.GetDefaultFolder (olFolderInbox)

Вы получаете только папку Входящие магазина доставки, чтобы найти предметы.

Свойство Stores класса Namespace возвращает объект коллекции Stores, который представляет все объекты Store в текущем профиле. Вы можете найти необходимый магазин, а затем использовать метод классакласса Store. Этот метод аналогичен методу GetDefaultFolder объекта NameSpace. Разница в том, что этот метод получает папку по умолчанию в хранилище доставки, связанную с учетной записью, тогда как NameSpace.GetDefaultFolder возвращает папку по умолчанию в хранилище по умолчанию для текущего профиля.

Set OutApp = CreateObject("Outlook.Application") 
Set OutMail = OutApp.CreateItem(olMailItem) 

Нет необходимости создавать новый экземпляр приложения Outlook в Outlook VBA.

Объектная модель Outlook предоставляет методы Find/FindNext или Restrict. Также может оказаться полезным метод AdvancedSearch класса Application.