VBA, MS Access MS Access в примерах

MS OutLook - Вывод списка элементов папки в Immediate Window

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

Private Sub GetOutlookItems()
'es - 23.09.2022
'Процедура просто выводит список элементов папки в Immediate Window
'---------------------------------------------------------------------------------------------------
Dim OutLookApp As Object
Dim OutLookNameSpace As Object
Dim OutLookFolder As Object
Dim OutLookItems As Object
Dim OutLookItem As Object
Dim iCount%, sVal$
'---------------------------------------------------------------------------------------------------
'Для справки:
' ... The OlDefaultFolders constants are
        'olFolderCalendar (9),
        'olFolderContacts (10),
        'olFolderDeletedItems (3),
        'olFolderDrafts (16),
        'olFolderInbox (6),
        'olFolderJournal (11),
        'olFolderNotes (12),
        'olFolderOutbox (4),
        'olFolderSentMail (5),
        'olFolderTasks (13).
'---------------------------------------------------------------------------------------------------
On Error GoTo GetOutlookContacts_Err

    Set OutLookApp = CreateObject("Outlook.Application")
    Set OutLookNameSpace = OutLookApp.GetNamespace("MAPI")
    Set OutLookFolder = OutLookNameSpace.GetDefaultFolder(6)

    Set OutLookItems = OutLookFolder.Items
    iCount = OutLookItems.Count
    
'Сортировка элементов (если нужно)
    'OutLookItems.Sort "ReceivedTime", False
    OutLookItems.Sort "SenderName", False
    
    For Each OutLookItem In OutLookItems
        sVal = ""
        With OutLookItem
            'Контакты:
'            sVal = sVal & .CompanyName & "; "
'            sVal = sVal & .BusinessAddressStreet & "; "
'            sVal = sVal & .BusinessAddressPostalCode & "; "
'            sVal = sVal & .BusinessAddressCity & "; "
'            sVal = sVal & .FullName& & "; "
'
'            sVal = sVal & .HomeAddressStreet & "; "
'            sVal = sVal & .HomeAddressPostalCode & "; "
'            sVal = sVal & .HomeAddressCity & "; "
'            sVal = sVal & .Email1Address
            
            
            'Почта:
            sVal = sVal & .EntryID & ";   "
            sVal = sVal & .Subject & ";"
            sVal = sVal & .SenderName & ";"
            sVal = sVal & CDate(.ReceivedTime) & ";"
        End With
        Debug.Print sVal
    Next

    Debug.Print String(80, "-")

GetOutlookContacts_End:
    On Error Resume Next
    OutLookApp.Quit
    Set OutLookFolder = Nothing
    Set OutLookApp = Nothing
    Set OutLookItem = Nothing
    Set OutLookItems = Nothing
    Set OutLookNameSpace = Nothing
    
    Err.Clear
    Exit Sub

GetOutlookContacts_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in sub GetOutlookContacts.", _
        vbCritical, "Произошла ошибка!"
    Debug.Print "GetOutlookContacts_Line: " & Erl & "."
    Err.Clear
    Resume GetOutlookContacts_End

End Sub


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