Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Access
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 17.01.2018, 17:05   #1
sasha_prof
Форумчанин
 
Регистрация: 06.01.2010
Сообщений: 292
По умолчанию Перебор писем Outlook в конкретной учетке

Добрый день!
Ребята, не смог найти в инете ответ на свой вопрос по перебору писем в аутлуке с помощью 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
sasha_prof вне форума Ответить с цитированием
Старый 17.01.2018, 17:29   #2
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Цитата:
Сообщение от sasha_prof Посмотреть сообщение
не смог найти в инете
но все же...
https://stackoverflow.com/questions/...tiple-mailboxs

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

никак не помогло?
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 17.01.2018, 17:43   #3
sasha_prof
Форумчанин
 
Регистрация: 06.01.2010
Сообщений: 292
По умолчанию

Вроде все понятно.
Пробую...
в коде ниже на первой строке выдает ошибку "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 вне форума Ответить с цитированием
Старый 17.01.2018, 18:53   #4
sasha_prof
Форумчанин
 
Регистрация: 06.01.2010
Сообщений: 292
По умолчанию

Ребята что это может быть?
sasha_prof вне форума Ответить с цитированием
Старый 17.01.2018, 23:25   #5
sasha_prof
Форумчанин
 
Регистрация: 06.01.2010
Сообщений: 292
По умолчанию

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

Код:
 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

Последний раз редактировалось sasha_prof; 18.01.2018 в 00:19.
sasha_prof вне форума Ответить с цитированием
Старый 18.01.2018, 10:38   #6
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

В Accounts.Count получаете 2?
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 18.01.2018, 12:27   #7
sasha_prof
Форумчанин
 
Регистрация: 06.01.2010
Сообщений: 292
По умолчанию

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


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Отправка писем в Outlook'e Parklane1488 Microsoft Office Excel 9 25.08.2014 16:46
перебор писем в OutLook'e mad_max.86@gmail.r Microsoft Office Access 7 12.05.2012 22:44
Автоматической рассылки писем через Outlook shkolyar Microsoft Office Excel 2 10.08.2011 15:29
Отбор писем по теме в Outlook. GoreProgrammist Microsoft Office Excel 8 28.03.2011 17:48
MS Excel и MS Outlook (2003) отсылка писем IceB Microsoft Office Excel 1 02.07.2007 13:32