Перебор писем Outlook в конкретной учетке

[sasha_prof]

Добрый день!
Ребята, не смог найти в инете ответ на свой вопрос по перебору писем в аутлуке с помощью VBA но в конкретной учетке (ящике).
Тоесть у меня на компе в аутлуке настроены 2 почтовых ящика. Перебирать письма нужно только по одному ящику.

Очень нужна ваша помощь...

Код которым перебираю просто письма нашел и работает...

Sub СохранитьВложения()

On Error Resume Next
Dim income(1000) As String
Dim FolderName As String
Dim Myf(50) As String
Dim data As Date
Dim MonNum As String
msg = 1

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")


' Тут идет проверка количества оцениваемых сообщений (бежать по всем входящим нет смысла, долго)
Max = myNameSpace.GetDefaultFolder(olFolderInbox).Items.Count + 1
' в частности здесь берется 10 последних сообщений
MesBuffer = 10
If Max < MesBuffer Then MesBuffer = Max - 1
'проверяем больше ли чем 0 сообщений
If Max > 0 Then
' цикл по этим сообщениям
For msg = Max - MesBuffer To Max
' считаем количство вложений
atcount = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments.Count
' смотрим тему
subj = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Subject
' вот тут нужно установить бесплатную прогу, которая убирает уведомления на чтение адресов
' расположена http://www.mapilab.com/ru/outlook/security прога бесплатна и для коммерческого и для некоммерческого использования

' смотрим ИФО отправителя
SendName = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).SenderName
' адрес отправителя
Send = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).SenderEmailAddress

' Если сообщение имеет статус непрочтеное и вложений не равно 0
If myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).UnRead = True And atcount <> 0 Then
' цикл по всем вложениям
For i = 1 To atcount
' наименование вложения
income(msg) = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments(1)

' тут можно сделать проверку наименования вложения
' проверка

' задаем место хранения (можно в зависимости от наименования вложения назначить путь по условию
pathOL = "E:\New\"
' Наименование файла вложения Адрес + Тема + НомерСообщения + НомерВложения + НаименованиеВложения (номер сообщения от конца)
MessageName = Send & subj & (Max - msg) & i & income(msg)
' проверяем файл на существование, если он существует в цикле создаем новую версию и ещё раз проверяем
N = 0
Do While Dir(pathOL & MessageName) <> ""
            N = N + 1
            MessageName = N & Send & subj & (Max - msg) & i & income(msg)
Loop
' сохраняем вложение
myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments(1).SaveAsFile pathOL & MessageName

'End If
Next i
' конец файлов непрочитанных со вложениями
End If
' помечаем сообщение как прочитанное (любое)
myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).UnRead = False
'следующее вложение
Next msg
' очищаем память
Erase income
' завершаем проверку на количество сообщений больше 0
End If

End Sub

[Aleksandr H.]

Сообщение от sasha_prof

не смог найти в инете

но все же...
https://stackoverflow.com/questions/...tiple-mailboxs

https://social.msdn.microsoft.com/Fo...rum=outlookdev

никак не помогло?

[sasha_prof]

Вроде все понятно.
Пробую...
в коде ниже на первой строке выдает ошибку "Run time error '438': Object doesnt support this proerty or method". Что то с библиотеками?

For Each oaccount In Application.Session.Accounts
  If oaccount = "1@email.com" Then
    Set Store = oaccount.DeliveryStore
    Set Folder = Store.GetDefaultFolder(olFolderInbox) 'here it selects the inbox folder of account.
    For Each Item In Folder.Items
      ' Code goes here
    Next Item
  End If
Next oaccount

[sasha_prof]

Ребята что это может быть?

[sasha_prof]

не переходит поче му то ко второму аккаунту в данном коде.
После первого аккаунта выходит с цикла

 Sub GetListOfAccounts()
    
    Dim Session As Outlook.Namespace
    Dim Report As String
    Dim myMail As Outlook.Items
    Dim Accounts As Outlook.Accounts
    Dim currentAccount As Outlook.Account
    
    Dim myItem As Outlook.MailItem
    Dim r
    Dim myFolder As Outlook.Folder
    
    
    Dim oAccount As Outlook.Folder
    
    
    Set Session = GetNamespace("MAPI")
    
    Set Accounts = Session.Accounts
    
    For Each currentAccount In Accounts
    
            
            Set myFolder = currentAccount.DeliveryStore.Session.GetDefaultFolder(olFolderInbox)
            Set myMail = myFolder.Items

                Cells.Clear
                Cells(1, 1) = "Îò êîãî"
                Cells(1, 2) = "E-mail"
                Cells(1, 3) = "Êîìó"
                Cells(1, 4) = "Òåìà"
                Cells(1, 5) = "Äàòà"
                Cells(1, 6) = "Òåëî ïèñüìà"
        
                r = 2
                For Each myItem In myMail
                    On Error Resume Next
                        Cells(r, 1) = myItem.SenderName
                        Cells(r, 2) = myItem.SenderEmailAddress
                        Cells(r, 3) = myItem.To
                        Cells(r, 4) = myItem.Subject
                        Cells(r, 5) = myItem.CreationTime
                        Cells(r, 6) = myItem.Body
                    On Error GoTo 0
                    r = r + 1
                Next myItem




        
        
    Next currentAccount
    
    
    
End Sub

[Aleksandr H.]

В Accounts.Count получаете 2?

[sasha_prof]

Какая то не понятная ситуация с єтими аккаунтами.
У меня почтовый ящик второй находит не в Accounts а в Folders.
Но вроде так тоже можно читать письма....