Outlook 2016 сбой нашего приложения при использовании по электронной почте

Question

После сборок Outlook 2016 (Office 365) в сентябре 2018 года функция электронной почты приложения .adp MS-Access (с поздним связыванием, использующая и не использующая погашение) завершится сбоем, а MSACCESS.EXE потерпит крах.Outlook 2016 не получает электронное письмо для обработки

Это поведение согласованно во многих средах Windows с использованием 32-разрядной версии Office Outlook 2016 (мы не можем использовать 64-разрядную версию Office, кстати)

В Microsoft Office Standard 2016(мы предполагаем, что это не Office 365), наше приложение Access не падает.Outlook 2013 тоже не вылетает.Такое поведение одинаково во многих средах Windows

Мы провели значительное количество испытаний, но не нашли ничего, что решило бы проблему

Пошаговое выполнение кода, который, по нашему мнению, был вызван использованиемсистемные папки, но жесткое кодирование пути к известной папке с полным разрешением вызывает ту же проблему.

При комментировании использования папок мы можем видеть, как электронная почта передается в Outlook, но затем следующий набор кода вылетает,Если мы закомментируем это, в следующий раз, когда мы нажмем, чтобы закрыть форму доступа после успешной отправки, у нас возникнет та же проблема;MSACCESS.EXE аварийно завершает работу

Последний процесс, который мы видим в Мониторе процессов:

... AppData \ Local \ Temp \ MSACCESS.EXE_c2rdll (201903071109167470) .log

, но этоWindows 10 не сохраняет файл достаточно долго, чтобы мы могли его просмотреть

Мы также заметили больше элементов в HKCU \ Software \ Microsoft \ Office \ 16.0 \ MAPI \ Resilidity \ StartupItems в настройках Office 365 по сравнению сстандартные ключи реестра Office, поэтому они переименованы в ключи Reg и заменены файлами MAPI, но без радости

Мы использовали / декомпилировали и запустили новый .adp (импорт всех объектов)

У кого-нибудь есть идеи?на этом?Заранее спасибо

Public Sub Send(Optional bLeaveFormOpen As Boolean)

  Dim mStream As ADODB.Stream
  Dim rsSend As ADODB.Recordset
  Dim strTempDir As String
  Dim strSavedFilename As String
  Dim strFileName As String
  Dim strFileArray() As String
  Dim intCounter As Integer
  Dim intFileNumber As Integer
  Dim objOutlook As Object
  Dim objOutlookItem As Object
  Dim objOutlookAttach As Object
  Dim objWord As Object
  Dim cmd As ADODB.Command
  Dim fileNum As Long
  Dim sSignaturePath As String
  Dim sSignature As String
  Dim strEmailBodyText As String
  Dim strHTMLEmailAttributes As String
  Dim strNote As String
  Dim objSafeForm As Object
  Dim strUserEmail As String
  Dim strExtension As String
  Dim strCSS As String
  Dim lngBodyPos As Long
  Dim lngBodyEndPos As Long
  Dim boolStripToDIVs As Boolean

  'For character testing
  Dim intTest As Integer

  On Error Resume Next
  Set objOutlook = CreateObject("Outlook.Application")
  If Err Then
    MsgBox "Email client Microsoft Outlook could not be started" & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Email has not been sent", vbCritical, Patron()
    GoTo Sub_Exit
  End If
  On Error GoTo Err_Handle

  If nulltozero(InStr(Me.txtTo, "@")) = 0 And nulltozero(InStr(Me.txtBcc, "@")) = 0 And nulltozero(InStr(Me.txtCc, "@")) = 0 Then
    MsgBox "An email address must be supplied" + vbCrLf + vbCrLf + "Email not sent", vbCritical, Patron()
    Set objOutlook = Nothing
    GoTo Sub_Exit
  End If

  If IsNull(Me.txtSubject) Or Len(Me.txtSubject) = 0 Or Me.txtSubject = " " Then
    MsgBox "An email subject must be entered" + vbCrLf + vbCrLf + "Email not sent", vbCritical, Patron()
    Set objOutlook = Nothing
    GoTo Sub_Exit
  End If

  On Error Resume Next
  Set objSafeForm = CreateObject("Redemption.SafeMailItem")
  If Err Then
    MsgBox "Outlook Redemption object library cannot be found.  Please contact your System Administrator", vbCritical, Patron()
    Exit Sub
  End If

  On Error GoTo Err_Handle
  DoCmd.Hourglass True
  Set objOutlookItem = objOutlook.CreateItem(0)
  objSafeForm.Item = objOutlookItem

  'Ensuring email address is entered when "To" is blank
  If IsNull(Me.txtTo) Or Me.txtTo = "" Then
    ' Add email address
    strUserEmail = UserEmail
    If strUserEmail <> "" Then
        objSafeForm.To = strUserEmail
    Else
        objSafeForm.To = Nz(Me.txtTo, "")
    End If
  Else
    objSafeForm.To = Nz(Me.txtTo, "")
  End If

  objSafeForm.cc = Nz(Me.txtCc, "")
  objSafeForm.Bcc = Nz(Me.txtBcc, "")
  objSafeForm.Subject = Nz(Me.txtSubject, "")

  strHTMLEmailAttributes = GetSetting("OurApplication", "Outlook", "HTMLEmailAttributes")
  If Len(Nz(strHTMLEmailAttributes)) > 0 Then
    fileNum = FreeFile
    Open strHTMLEmailAttributes For Input As fileNum
    strHTMLEmailAttributes = Input(LOF(fileNum), fileNum)
    Close fileNum
  End If

  strNote = Nz(Me.HTMLed1.DocumentHTML, "")

    strCSS = Replace(Me.HTMLed1.CSSText, "body {", "")
    strCSS = Replace(strCSS, "}", "")
    strNote = "<DIV style=""" & strCSS & """>" & strNote & "</DIV>"

  sSignature = GetSetting("OurApplication", "Outlook", "SignaturePath", "")

  On Error GoTo Err_Sig
  If Len(Nz(sSignature)) > 0 Then
    fileNum = FreeFile
    Open sSignature For Input As fileNum
    sSignature = Input(LOF(fileNum), fileNum)
    Close fileNum
    If InStr(1, sSignature, "<body>", vbTextCompare) > 0 Then
        lngBodyPos = InStr(1, sSignature, "<body>", vbTextCompare) + 5
    ElseIf InStr(1, sSignature, "<body", vbTextCompare) > 0 Then
        lngBodyPos = InStr(1, sSignature, "<body", vbTextCompare) + 4
        lngBodyPos = InStr(lngBodyPos, sSignature, ">", vbTextCompare)
    Else
        lngBodyPos = 0
    End If
    boolStripToDIVs = GetUserOption(Forms!Logon!ChooseUser, "StripToDIVS")
    If boolStripToDIVs Then
        lngBodyEndPos = InStrRev(sSignature, "</body>", -1, vbTextCompare)
        strEmailBodyText = strNote & "<BR /><BR />" & Mid(sSignature, lngBodyPos + 1, Len(sSignature) - (Len(sSignature) - (lngBodyEndPos - 2)) - lngBodyPos + 1)
    Else
        strEmailBodyText = Left(sSignature, lngBodyPos) & strNote & "<BR /><BR />" & right(sSignature, Len(sSignature) - lngBodyPos)
    End If
  Else
    strEmailBodyText = strNote
  End If

  On Error GoTo Err_Handle

  objSafeForm.HTMLBody = strEmailBodyText

  ReDim Preserve strFileArray(1)
  strTempDir = ReturnTempDir
  If Not (m_rsAttachments.EOF And m_rsAttachments.BOF) Then m_rsAttachments.MoveFirst
  Do Until m_rsAttachments.EOF
    If m_rsAttachments("CV") Then
        'is a cv

        ' Set the filename
        Select Case Me.cboEmailFilenameFormat
            Case 0 ' Not set
                If IsNull(m_rsAttachments("FullName")) Then
                    strFileName = "(" & m_rsAttachments("ID") & ") CV"
                Else
                    strFileName = m_rsAttachments("FullName")
                End If
            Case 1 ' Full names
                If IsNull(m_rsAttachments("FullName")) Then
                    strFileName = "(" & m_rsAttachments("ID") & ") CV"
                Else
                    strFileName = m_rsAttachments("FullName")
                End If
            Case 2 ' Anonymous
                strFileName = "(" & m_rsAttachments("ID") & ") CV"
            Case 3 ' Description
                If IsNull(m_rsAttachments("Description")) Then
                    strFileName = "(" & m_rsAttachments("ID") & ") CV"
                Else
                    strFileName = m_rsAttachments("Description")
                End If
        End Select

        If m_rsAttachments("OLE") Then
            If IsOLEPDF(m_rsAttachments("Document")) Then
                'is a PDF file and needs saving direct to file
                Set mStream = New ADODB.Stream
                mStream.Type = adTypeBinary
                mStream.Open
                mStream.Write m_rsAttachments("Document")
                If right(strFileName, 4) = ".pdf" Then
                    strSavedFilename = strTempDir & strFileName
                Else
                    strSavedFilename = strTempDir & strFileName & ".pdf"
                End If
                mStream.SaveToFile strSavedFilename, adSaveCreateOverWrite
            Else
                'is ole wrapped so remove wrapper
                RestoreObject m_rsAttachments("Document"), strFileName, strTempDir, "", strSavedFilename
                strSavedFilename = strTempDir & strSavedFilename
            End If
        Else
            If IsOLEPDF(m_rsAttachments("Document")) Then
                'is a PDF file and needs saving direct to file
                Set mStream = New ADODB.Stream
                mStream.Type = adTypeBinary
                mStream.Open
                mStream.Write m_rsAttachments("Document")
                If right(strFileName, 4) = ".pdf" Then
                    strSavedFilename = strTempDir & strFileName
                Else
                    strSavedFilename = strTempDir & strFileName & ".pdf"
                End If
                mStream.SaveToFile strSavedFilename, adSaveCreateOverWrite
            Else
                'is binary so save direct to file
                Set mStream = New ADODB.Stream
                mStream.Type = adTypeBinary
                mStream.Open
                mStream.Write m_rsAttachments("Document")
                Select Case right(strFileName, 3)
                    Case "doc"
                    Case "bmp"
                    Case "gif"
                    Case "jpg"
                    Case "pdf"
                    Case "rtf"
                    Case "txt"
                    Case "xls"
                    Case "pps"
                    Case "ppt"
                    Case Else
                        Select Case right(strFileName, 4)
                            Case "docx"
                            Case "xlsx"
                            Case "pptx"
                            Case Else
                                ' Try to get the file extension from the recordset
                                If Len(m_rsAttachments("FileExtension")) Then
                                    strFileName = strFileName & "." & m_rsAttachments("FileExtension")
                                Else
                                    strFileName = strFileName & ".doc"
                                End If
                        End Select
                End Select
                strSavedFilename = strTempDir & strFileName
                mStream.SaveToFile strSavedFilename, adSaveCreateOverWrite
            End If
        End If
        'save filename to array
        ReDim Preserve strFileArray(UBound(strFileArray) + 1)
        strFileArray(UBound(strFileArray)) = strSavedFilename

      Else
        'Not a cv
        If IsNull(m_rsAttachments("Description")) Then
            strFileName = "File" & m_rsAttachments("ID")
        Else
            strFileName = m_rsAttachments("Description")
        End If

        ' Set the filename
        If IsNull(m_rsAttachments("FullName")) Then
            strFileName = "File" & m_rsAttachments("ID")
        Else
            strFileName = m_rsAttachments("FullName")
        End If


        If m_rsAttachments("OLE") = 1 Then
            'is ole wrapped so remove wrapper
            RestoreObject m_rsAttachments("Document"), strFileName, strTempDir, "", strSavedFilename
            strSavedFilename = strTempDir & strSavedFilename
        Else
            'is binary so save direct to file
            Set mStream = New ADODB.Stream
            mStream.Type = adTypeBinary
            mStream.Open
            mStream.Write m_rsAttachments("Document")
            Select Case right(strFileName, 3)
                Case "doc"
                Case "bmp"
                Case "gif"
                Case "jpg"
                Case "pdf"
                Case "rtf"
                Case "txt"
                Case "xls"
                Case "pps"
                Case "ppt"
                Case Else
                    Select Case right(strFileName, 4)
                        Case "docx"
                        Case "xlsx"
                        Case "pptx"
                        Case Else
                            ' Try to get the file extension from the recordset
                            If Len(m_rsAttachments("FileExtension")) Then
                                strFileName = strFileName & "." & m_rsAttachments("FileExtension")
                            Else
                                strFileName = strFileName & ".doc"
                            End If
                    End Select
            End Select
            strSavedFilename = strTempDir & GetFileNameFromPath(strFileName)
            mStream.SaveToFile strSavedFilename, adSaveCreateOverWrite
        End If
        'save filename to array
        ReDim Preserve strFileArray(UBound(strFileArray) + 1)
        strFileArray(UBound(strFileArray)) = strSavedFilename
    End If

    ' attach docs to email
    ' according to MSDN Attachments.Add method help, Outlook benefits from a message being saved before
    ' an attachment is added
    If Me.chkAutoSend = False Then
        objOutlookItem.Save
        objOutlookItem.Attachments.Add strSavedFilename
    Else
        Set objOutlookAttach = objSafeForm.Attachments.Add(strSavedFilename)
    End If
    m_rsAttachments.MoveNext
  Loop

  On Error Resume Next
    If Me.chkAutoSend Then
        objSafeForm.Send
    Else
        objOutlookItem.Save
        objOutlookItem.Display
    End If

  If Err.Number <> 0 Then
    If Err.Number = 287 Then
        MsgBox "Sending email was cancelled", vbExclamation
    Else
        MsgBox "The following error occurred: " & Error$ & Chr(10) & Chr(13) & Chr(10) & Chr(13) & "Please take a note and contact us on our phone number!", 16, Patron()
    End If
  Else

  End If

  On Error Resume Next
  ' clean up temp files
  If UBound(strFileArray) > 1 Then
    For intCounter = 2 To UBound(strFileArray)
        Kill strFileArray(intCounter)
    Next
  End If

  If Not bLeaveFormOpen Then DoCmd.Close acForm, Me.Name

Sub_Exit:
  On Error Resume Next
  Set objOutlook = Nothing
  Set objOutlookItem = Nothing
  Set objOutlookAttach = Nothing
  DoCmd.Hourglass False
  Exit Sub

Err_Handle:
  MsgBox "The following error occurred: " & Error$ & Chr(10) & Chr(13) & Chr(10) & Chr(13) & "Please take a note and contact us on our phone number!", 16, Patron()
  Resume Sub_Exit

Err_Sig:
  MsgBox "The following error occurred: Signature file pathway incorrect." & Chr(10) & Chr(13) & Chr(10) & Chr(13) & "Please take a note and contact us on our phone number!", 16, Patron()
  Resume Sub_Exit

End Sub