自2018年9月构建Outlook 2016（Office 365）起，我们的MS-Access .adp应用程序电子邮件（使用和不使用赎回绑定的后期绑定）功能将失败并且MSACCESS.EXE将崩溃。 Outlook 2016未收到要处理的电子邮件
此行为在使用32位Office Outlook 2016（我们不能使用64位Office，顺便说一句）的许多Windows环境中都是一致的
在Microsoft Office Standard 2016（我们假设这是非Office 365安装）中，我们的Access应用程序不会崩溃。 Outlook 2013也不会崩溃。在许多Windows环境中，这种行为都是一致的
我们已经进行了大量测试，但没有解决问题
逐步浏览我们认为是由于使用系统文件夹而导致的代码，但是对已知的完全许可文件夹的路径进行硬编码会导致相同的问题。
在注释掉文件夹的使用时，我们可以看到一封电子邮件传递到Outlook，但是随后我们的下一组代码崩溃。如果我们将其注释掉，则在成功发送后下一次单击以关闭“访问”表单时，我们会遇到相同的问题； MSACCESS.EXE崩溃
我们在过程监视器中看到的最后一个过程是
... AppData \ Local \ Temp \ MSACCESS.EXE_c2rdll（201903071109167470）.log
但是Windows 10对该文件的保留时间不足以供我们查看
我们还注意到，与标准Office reg键相比，Office 365设置上HKCU \ Software \ Microsoft \ Office \ 16.0 \ MAPI \ Resiliency \ StartupItems中的项目更多，因此重命名了Reg键并替换了MAPI文件，但没有欢乐
我们已经使用/ decompile并启动了一个新的.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