TopPicLogo TopPicText

MS OutLook - Получение списка сообщений папки "Входящие" (или другой)

Просто как пример работы с приложением ....

OPrivate Function esGetEmailMessages(Optional FolderID As Integer = 6) As String
'es - GR:21.02.2001 - LE:17.10.2012
'Чисто для примера ....
'Функция Возвращает список сообщений из INBOX-а (По умолчанию) через точку с запятой в (4 столбца)
' =   Номер ; Тема ; ОтКого ; Время отправки
'--------------------------------------------------------------------
' Ahtung!!!
'   Требует ссылки на библиотеку MS OutLook XX.X Object Library
'   C:\PROGRAM FILES\MICROSOFT OFFICE\OFFICE\msoutl.olb
'--------------------------------------------------------------------
'Для справки:
' ... The OlDefaultFolders constants are
        'olFolderCalendar (9),
        'olFolderContacts (10),
        'olFolderDeletedItems (3),
        'olFolderDrafts (16),
        'olFolderInbox (6),
        'olFolderJournal (11),
        'olFolderNotes (12),
        'olFolderOutbox (4),
        'olFolderSentMail (5),
        'olFolderTasks (13).
'--------------------------------------------------------------------

Dim OutLookApp As New Outlook.Application
Dim OutLookNameSpace As Outlook.NameSpace
Dim MesItems As Outlook.Items
Dim MesItem As Outlook.MailItem

Dim MesEntryID As String    'Уникальный ID сообщения
Dim MesSubject As String    'Тема (заголовок)
Dim MesFrom As String       'От
Dim MesReceived As Date     'Когда Отправлено

On Error GoTo esGetEmailMessages_Err

Set OutLookApp = New Outlook.Application
Set OutLookNameSpace = OutLookApp.GetNamespace("MAPI")
Set MesItems = OutLookNameSpace.GetDefaultFolder(FolderID).Items
       
For Each MesItem In MesItems
    With MesItem
        MesEntryID = .EntryID
        MesSubject = .Subject
        MesFrom = .SenderName
        MesReceived = CDate(.ReceivedTime)
        esGetEmailMessages = esGetEmailMessages & _
            MesEntryID & ";" & _
            MesSubject & ";" & _
            MesFrom & ";" & _
            MesReceived & ";"
    End With
Next MesItem
    On Error Resume Next
    OutLookApp.Quit
    
    Set OutLookApp = Nothing
    Set MesItem = Nothing
    Set MesItems = Nothing
    Set OutLookNameSpace = Nothing

Exit Function
esGetEmailMessages_Err:
    MsgBox Err.Description
End Function

Ahtung!!!
   Требует ссылки на библиотеку MS OutLook XX.X Object Library
   C:\PROGRAM FILES\MICROSOFT OFFICE\OFFICE\msoutl.olb

Назад ToTop
L.E. 17.10.2012
Рейтинг@Mail.ru