Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
28.03.2024, 14:40:51

Войти
Добавляйтесь в нашу группу ВКонтакте - будьте в курсе всех новых событий сайта, узнавайте первым обо всех акциях и новых статьях!
33 233 Сообщений в 5 454 Тем от 6 750 Пользователей
Последний пользователь: Alex1210
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Excel и VBA
| | |-+  Сделать цикл по всем учетным записям Входящие Outlook
Страниц: [1] 2  Все   Вниз
Печать
Автор Тема: Сделать цикл по всем учетным записям Входящие Outlook  (Прочитано 8561 раз)
0 Пользователей и 1 Гость смотрят эту тему.
Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« : 24.06.2018, 11:24:13 »

Здравствуйте.
Имеется код, позволяющий списком, во вновь создаваемом файле Excel, вывести эл.адреса получателей писем из моей папки Входящие в Outlook (Inbox). Не устраивает в этом коде то, что он просматривает папку Входящие лишь одной из моих учетных записей в Outlook. А у меня их там несколько. Есть идеи/посказки, что можно/нужно изменить, чтобы выводились адреса Входящих более одного аккаунта Outlook ? Может, дело в инструкции
Код: (vb)
Set fldr = olApp.Session.GetDefaultFolder(6)  '6 = olFolderInbox
  ?
Код полностью :
Код: (vb)
Option Explicit

Dim colAddress As Collection

Sub main_Inbox_VL() ‘Запускаем эту процедуру

    Dim olApp   As Object 'Outlook.Application
    Dim fldr    As Object 'Outlook.Folder
    Dim arr()
    Dim Counter_VL

    Set colAddress = New Collection

    Set olApp = CreateObject("Outlook.Application")

    'обработка папки Входящие Inbox с подпапками
    Set fldr = olApp.Session.GetDefaultFolder(6)  '6 = olFolderInbox
    Call processFolder(fldr)

        On Error GoTo a1 'обработка ошибки на случай, если в папке 0 сообщений

    'cоздание списка адресов в новом файле Excel
ReDim arr(1 To colAddress.Count, 1 To 1)
    For Counter_VL = 1 To colAddress.Count
        arr(Counter_VL, 1) = colAddress(Counter_VL)
    Next Counter_VL

    Application.Workbooks.Add.Worksheets(1).Range("B1").Resize(colAddress.Count) = arr

Exit Sub
a1:
MsgBox "Ошибка в процедуре Sub main_Inbox_VL()!"
'Resume Next
End Sub 'main_Inbox_VL()

Sub processFolder(ByVal pFolder As Object) 'Outlook.Folder)
    Dim fldr    As Object 'Outlook.Folder
    Dim item    As Object
    Dim mail    As Object 'Outlook.mailItem
    Dim rcpnt   As Object 'Outlook.Recipient
    Dim Counter_VL

    'просмотром элементов в папке
    For Each item In pFolder.Items
        If item.Class = 43 Then ' 43 = olMail
            Set mail = item
            Counter_VL = Counter_VL + 1
            'If Counter_VL > 10 Then Exit For
            Debug.Print "Mail " & Counter_VL & " in folder " & pFolder.Name
            Call addAddress(mail.Sender, mail.Sender.Address) 'запомнить Отправителя Sender
' ниже – для Исходящие Oubox
'            For Each rcpnt In mail.Recipients 'цикл по Получателям Recepients
'                Call addAddress(rcpnt.AddressEntry, rcpnt.Address) ' запомнить Получателей Recepients
'            Next rcpnt
            Set mail = Nothing
        End If
    Next item

    'смотреть в папках (первого уровня)
    For Each fldr In pFolder.Folders
        Call processFolder(fldr) 'recursion
    Next fldr
End Sub

Sub addAddress(ByVal pAddressEntry As Object, _
                ByVal altaddr As String) 'Outlook.AddressEntry
    Dim pa      As Object 'PropertyAccessor
    Dim addr    As String
    Set pa = pAddressEntry.PropertyAccessor
    On Error Resume Next
    addr = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E")
    If addr = "" Then addr = altaddr
    colAddress.Add addr, addr 'добавление уникального адреса
    On Error GoTo 0
End Sub

Спасибо.
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #1 : 24.06.2018, 12:34:34 »

Надо подключаться через MAPI
Код: (vb)
Dim olApp as object, oNSpace as object, oFldr as object, x as long
Set olApp = CreateObject("Outlook.Application")
'получаем доступ к папкам почты
Set oNSpace = olApp.GetNamespace("MAPI")
'просматриваем каждую учетную запись Outlook
For x = 1 To oNSpace.Folders.Count
     Set oFldr = oNSpace.Folders(x).Folders(2) 'папка входящие учетной записи
     'какой-то код обработки входящих
Next
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« Ответ #2 : 27.06.2018, 10:15:59 »

 Здравствуйте, The_Prist.
Спасибо ! Теперь, с Вашим кодом, действительно удается считывать содержимое папок/подпапок Входящие всех имеющихся учетных записей.

Третий день пытаюсь увязать место, отмеченное в Вашем коде " the main code", с моим тем самым основным кодом. Провал пока настолько полный, что даже не уверена, понимаю ли, чего не понимаю (возможно, привязку по уровням), и показать нечего.
Надеюсь, будет повод вернуться в эту тему.
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #3 : 27.06.2018, 10:32:22 »

Я в дебри Вашего кода тоже не погружался. На вскидку, должно быть что-то вроде:
Код: (vb)
Option Explicit  
 
Dim colAddress As Collection 
 
Sub main_Inbox_VL() ‘Запускаем эту процедуру 
 
    Dim olApp   As Object 'Outlook.Application 
    Dim fldr    As Object 'Outlook.Folder 
    Dim arr() 
    Dim Counter_VL 
 
    Set colAddress = New Collection
 
    Set olApp = CreateObject("Outlook.Application")
 
    'обработка папки Входящие Inbox с подпапками 
    Set oNSpace = olApp.GetNamespace("MAPI")
    'просматриваем каждую учетную запись Outlook
    For x = 1 To oNSpace.Folders.Count
         Set fldr = oNSpace.Folders(x).Folders(2) 'папка входящие учетной записи
         'какой-то код обработки входящих
         Call processFolder(fldr)
    Next

        On Error GoTo a1 'обработка ошибки на случай, если в папке 0 сообщений 
 
    'cоздание списка адресов в новом файле Excel 
ReDim arr(1 To colAddress.Count, 1 To 1) 
    For Counter_VL = 1 To colAddress.Count 
        arr(Counter_VL, 1) = colAddress(Counter_VL) 
    Next Counter_VL 
 
    Application.Workbooks.Add.Worksheets(1).Range("B1").Resize(colAddress.Count) = arr 
 
Exit Sub 
a1: 
MsgBox "Ошибка в процедуре Sub main_Inbox_VL()!" 
'Resume Next 
End Sub 'main_Inbox_VL() 
 
Sub processFolder(ByVal pFolder As Object) 'Outlook.Folder) 
    Dim fldr    As Object 'Outlook.Folder 
    Dim item    As Object 
    Dim mail    As Object 'Outlook.mailItem 
    Dim rcpnt   As Object 'Outlook.Recipient 
    Dim Counter_VL 
 
    'просмотром элементов в папке 
    For Each item In pFolder.Items 
        If item.Class = 43 Then ' 43 = olMail 
            Set mail = item 
            Counter_VL = Counter_VL + 1 
            'If Counter_VL > 10 Then Exit For 
            Debug.Print "Mail " & Counter_VL & " in folder " & pFolder.Name 
            Call addAddress(mail.Sender, mail.Sender.Address) 'запомнить Отправителя Sender 
' ниже – для Исходящие Oubox 
'            For Each rcpnt In mail.Recipients 'цикл по Получателям Recepients 
'                Call addAddress(rcpnt.AddressEntry, rcpnt.Address) ' запомнить Получателей Recepients 
'            Next rcpnt 
            Set mail = Nothing 
        End If 
    Next item 
 
    'смотреть в папках (первого уровня) 
    For Each fldr In pFolder.Folders 
        Call processFolder(fldr) 'recursion 
    Next fldr 
End Sub 
 
Sub addAddress(ByVal pAddressEntry As Object, _ 
                ByVal altaddr As String) 'Outlook.AddressEntry 
    Dim pa      As Object 'PropertyAccessor 
    Dim addr    As String 
    Set pa = pAddressEntry.PropertyAccessor 
    On Error Resume Next 
    addr = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E") 
    If addr = "" Then addr = altaddr 
    colAddress.Add addr, addr 'добавление уникального адреса 
    On Error GoTo 0 
End Sub
 
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« Ответ #4 : 28.06.2018, 09:19:14 »

Удалось увязать два кода, чтобы хотя бы не было ошибок при компиляции и выполнении. Результат - тот же, что и с первоначальным кодом, то есть список адресов получаем, но только по одному аккаунту.
Откуда следует, что считать аккаунты удается, записываются они, как мне кажется, в переменную oNSpace; а вот считать их оттуда и пройтись по каждому циклом - пока нет.
Делаю это так, и что-то неверно, так как по всем аккаунтам программа так и не проходит у меня :
Код: (vb)
        For Each Fldr In oNSpace.Folders
        Call processFolder(Fldr) 'recursion
    Next Fldr

Вызываемый Sub processFolder(Fldr) работает как надо, это проверено, так как он исправно создает список адресов для одного аккаунта.
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #5 : 29.06.2018, 10:25:34 »

Я же Вам Выше код Ваш выложил со своей "добавкой" - не получается им? Потому что у меня он чуть иначе выглядит, нежели у Вас. Сравните.
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« Ответ #6 : 01.07.2018, 19:29:41 »

Здравствуйте.
Да, Вашим кодом не получается пока. Наверное, многого не понимаю. Ищу. Будет результат - обязательно напишу в форум.
Всего доброго !
Записан
boa
Старожил
****

Репутация: +22/-0
Офлайн Офлайн

Сообщений: 252


Доброта спасет мир...


Просмотр профиля WWW
« Ответ #7 : 01.07.2018, 21:27:40 »

Не прочитанные в Бизнес-Скайпе сообщения сохраняются в папке Входящие
может в этом причина(они не имеют Отправителя)
перед строкой
Код: (vb)
Call addAddress(mail.Sender, mail.Sender.Address) 'запомнить Отправителя Sender

добавьте
Код: (vb)
on error resume next
« Последнее редактирование: 01.07.2018, 21:30:04 от boa » Записан

Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« Ответ #8 : 03.07.2018, 09:47:49 »

Здравствуйте, The_Prist.
Здравствуйте, Boa.
Я с хорошей новостью. Всё получилось.
Единственное, что мне пришлось изменить, The_Prist, в Вашем коде "на вскидку", это параметр в строке 20
Код: (vb)
Set fldr = oNSpace.Folders(x).Folders(2)
, где я заменила параметр (2) соответствует папке Исходящие на (1) - Входящие. Это, конечно, не принципиально, но меня сбивало, так как не получалось проверить правильность результата.

Спасибо Вам огромное. Не знаю, сколько лет мне пришлось бы блуждать без Ваших весомых подсказок Улыбка.
Спасибо, Boa, за Ваше замечание. Учту на будущее.

Ураааа !
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #9 : 04.07.2018, 08:58:40 »

На самом деле именно 2 это входящие. Если у Вас для Входящих 1 - это странно, т.к. параметр глобальный.
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« Ответ #10 : 04.07.2018, 12:13:57 »

хм... стоит попробовать разобраться, с чем это связано. В интернете я не смогла найти расшифровку и возможное количество параметра в скобках.
Знаете ли Вы их ?
Возможно, это 12 встроенных папок в outlook (соответственно, параметр может принимать значение от 1 до 12) ?
Об этих 12 папках я нашла кое-что в учебниках, но там это в связи с  методом GetDefaultFolder()..
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #11 : 04.07.2018, 13:51:40 »

Попробуйте выполнить такую процедуру:
Код: (vb)
    Dim x,xx
    For x = 1 To oNSpace.Folders.Count
        Debug.Print oNSpace.Folders(x).Name & " ==> " & x
        For xx = 1 To oNSpace.Folders(x).Folders.Count
            Debug.Print vbTab & oNSpace.Folders(x).Folders(xx).Name & " ==> " & xx
        Next
        Debug.Print "============== "
    Next

В окне Immediate(Ctrl+G) будет выведен список имен всех учетных записей и всех их папок с номерами.
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« Ответ #12 : 08.07.2018, 17:28:45 »

Здравствуйте, спасибо.
Пробую, на шаге
Код: (vb)
    For x = 1 To oNSpace.Folders.Count
ошибка VAriable not defined.

Я попыталась ее объявить, это повлекло за собой еще изменения, но код так и не срабатывает :
Код: (vb)
Option Explicit
Sub Liste()
Dim x, xx
Dim oNSpace As Object
Dim olApp   As Object 'Outlook.Application

Set oNSpace = olApp.GetNamespace("MAPI")
Set olApp = CreateObject("Outlook.Application")

   
    With oNSpace
    For x = 1 To oNSpace.Folders.Count
        Debug.Print oNSpace.Folders(x).Name & " ==> " & x
        For xx = 1 To oNSpace.Folders(x).Folders.Count
            Debug.Print vbTab & oNSpace.Folders(x).Folders(xx).Name & " ==> " & xx
        Next
        Debug.Print "============== "
    Next
    End With
End Sub
Записан
Valetnina
Постоялец
***

Репутация: +2/-0
Офлайн Офлайн

Сообщений: 153



Просмотр профиля WWW E-mail
« Ответ #13 : 08.07.2018, 18:51:41 »

Возвращаясь к вопросу о параметре в скобках в конце выражения
Код: (vb)
Set fldr = oNSpace.Folders(x).Folders(1)
:
я протестировала из VBA четыре своих почтовых ящика, меняя цифру от 1 и выше.  
В трех случаях из четырёх у меня Folders(1) выводит Inbox Входяшие. Наверное, это неверно называть "глобальным" параметром в таком случае...
В четвертом ящике Folders(1) возвращает Trash и Folders(2) - Inbox.
  
Папки для VBA нумеруются не 100% стабильно. У них и порядковый номер и количество варьируется.

« Последнее редактирование: 08.07.2018, 18:58:34 от Valetnina » Записан
boa
Старожил
****

Репутация: +22/-0
Офлайн Офлайн

Сообщений: 252


Доброта спасет мир...


Просмотр профиля WWW
« Ответ #14 : 08.07.2018, 20:42:52 »

Valetnina,
поменяйте строки местами
Код: (vb)
Set olApp = CreateObject("Outlook.Application")
Set oNSpace = olApp.GetNamespace("MAPI")
Записан

Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Страниц: [1] 2  Все   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru