Private OL_ItemMail As Outlook.MailItem

'спиcок писем в папке "входящие"
Function EmailInbox()
Dim OL_App As Outlook.Application
Dim OL_NameSpace As Outlook.NameSpace
Dim OL_FolderMail As Outlook.MAPIFolder
Dim InitiationMaill As Long, HEARINGMaill As Long
Dim myItems As Outlook.Items
Dim n As Long

   On Error GoTo EmailInbox_Error
 
er = 1
' получаем объект Outlook
Set OL_App = CreateObject("Outlook.Application")

er = 2
'получаем Namespace
Set OL_NameSpace = OL_App.GetNamespace("MAPI")

er = 3
' получаем ссылку на папку Входящие
Set OL_FolderMail = OL_NameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = OL_FolderMail.Items 

er = 4
' перебираем все письма в папке
For Each OL_ItemMail In myItems 
    
    With OL_ItemMail
er = 50
        If .UnRead Then ' фильтр по непрочитанным
              ' здесь идет обработка писем
        End If
    End With
' на 1800 письме после следующей строки сразу выпадает в ошибку
Next
    
   On Error GoTo 0
   Exit Function

EmailInbox_Error:
' здесь обработка ошибок    
End Function

    With OL_ItemMail
er = 50
        If .UnRead Then ' фильтр по непрочитанным
              ' здесь идет обработка писем
        End If
    End With

    For Each OL_ItemMail In OL_FolderMail.Items.Restrict("[Unread]=TRUE")
              ' здесь идет обработка писем
    End With

        lngFrom = InStr(1, strBody, "AAA Case No.:") 
        If Nz(lngFrom, 0) <> 0 Then
            lngFrom = lngFrom + Len("AAA Case No.:") 
            lngFrom = InStr(lngFrom + 2, strBody, "" & Chr$(13) & Chr$(10) & "") 
            lngTo = InStr(lngFrom + 2, strBody, "" & Chr$(13) & Chr$(10) & "") 
            strTemp = Trim(Mid(strBody, lngFrom + 2, lngTo - lngFrom - 2))
            AAA = Trim(strTemp)
            If Len(AAA) = 0 Then ResultProcessed = ResultProcessed & "; AAA Case No.: = NULL"
'            Debug.Print "AAA - " & AAA & "///"
        End If

    With oRegEx
        .Pattern = "<!*[^<>]*>"    'html tags and comments
        .Global = True
        .IgnoreCase = True
        .MultiLine = True
    End With
RemoveHTML = oRegEx.Replace(MyStr, "")

If InternetGetConnectedState(0&, 0&) Then
    DoCmd.Hourglass True
    ' получаем объект Outlook
    Set OL_App = CreateObject("Outlook.Application")
    
er = 2
    'получаем Namespace
    Set OL_NameSpace = OL_App.GetNamespace("MAPI")
    '?OL_NameSpace.CurrentUser
er = 3
    ' получаем ссылку на папку Черновики
    Set OL_FolderMail = OL_NameSpace.GetDefaultFolder(olFolderDrafts)
    Set myItems = OL_FolderMail.Items
    
er = 4
    ' перебираем все письма в папке
    For Each OL_ItemMail In myItems
        If OL_ItemMail.Class = olMail Then
            Set OL_ItemMail1 = OL_ItemMail
            With OL_ItemMail1
er = 5
                MySubject = Trim(Mid(.Subject, 1, 27))
                '   выборка данных для записи или сравнения
                If MySubject = "INITIAL SETTLEMENT PROPOSAL" Then
er = 6
                    .Send
                    InitiationMaill = InitiationMaill + 1
                End If
            End With
        End If
    Next
er = 7
        MsgBox "" & InitiationMaill & " Initial settlement offers have been successfully sent.", , "Sending Initiation"
Else
    MsgBox "No internet connection!"
End If

DoCmd.Hourglass False