Set fldr = olApp.Session.GetDefaultFolder(6) '6 = olFolderInbox
Option ExplicitDim colAddress As CollectionSub 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оздание списка адресов в новом файле ExcelReDim 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) = arrExit Suba1:MsgBox "Ошибка в процедуре Sub main_Inbox_VL()!"'Resume NextEnd 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 fldrEnd SubSub 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 0End Sub
Dim olApp as object, oNSpace as object, oFldr as object, x as longSet olApp = CreateObject("Outlook.Application")'получаем доступ к папкам почтыSet oNSpace = olApp.GetNamespace("MAPI")'просматриваем каждую учетную запись OutlookFor x = 1 To oNSpace.Folders.Count Set oFldr = oNSpace.Folders(x).Folders(2) 'папка входящие учетной записи 'какой-то код обработки входящих Next
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
For Each Fldr In oNSpace.Folders Call processFolder(Fldr) 'recursion Next Fldr
Call addAddress(mail.Sender, mail.Sender.Address) 'запомнить Отправителя Sender
on error resume next
Set fldr = oNSpace.Folders(x).Folders(2)
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
For x = 1 To oNSpace.Folders.Count
Option ExplicitSub Liste()Dim x, xxDim oNSpace As ObjectDim olApp As Object 'Outlook.ApplicationSet 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 WithEnd Sub
Set fldr = oNSpace.Folders(x).Folders(1)
Set olApp = CreateObject("Outlook.Application")Set oNSpace = olApp.GetNamespace("MAPI")