如何恢复MSAccess中因安全变更失效的邮件宏功能

我们公司有一套定制开发的Access数据库，其中的邮件发送模块突然无法运行，原因是安全防护措施变更，现在需要调整设置恢复功能，但对模块内多数函数逻辑不熟悉，求解决思路。附带的核心邮件发送函数是基于CDO的Gmail SMTP配置。

核心问题分析 #

这段代码依赖Gmail的SMTP服务发送邮件，而Gmail近年已淘汰用户名+密码直接登录的方式，转而要求应用专用密码或OAuth2认证，这是最可能的安全变更触发点。

分步解决思路 #

一、优先处理Gmail认证方式 #

• 启用2步验证并生成应用专用密码：如果发件邮箱开启了2步验证，必须用应用专用密码替换原密码（即strEmailPWD参数）。应用专用密码需在Google账号安全设置中生成，仅对开启2步验证的账号有效。
• 未开启2步验证的情况：Google已在2022年停止支持非OAuth2的未验证应用，所以“允许不太安全的应用”选项已失效，建议直接开启2步验证并使用应用专用密码。
• 验证SMTP端口配置：代码当前使用465端口+SSL，这是Gmail的标准配置，也可以尝试切换到587端口（代码中已有注释），保持SSL开启即可。

二、修复代码中的明显问题 #

• 删除重复函数：代码中出现了两次完全相同的ValidateEmailAddress函数，Access编译时会报错，必须删除其中一个，保留唯一版本。
• 优化错误提示：当前错误处理只显示通用提示，建议修改errHandler部分，加入具体错误代码和描述，方便定位问题，比如把邮件发送的错误提示改成：

  MsgBox prompt:="发送邮件出错 (" & strEmailFROM & "): " & Err.Number & " - " & Err.Description, _
      buttons:=vbCritical + vbOKOnly, title:="邮件发送失败"
  

• 补全未处理的参数：原代码未用到Attachment和CC参数，可添加对应逻辑（见下方整理后的代码）。

三、其他安全相关排查 #

• 检查网络限制：确认公司防火墙/代理是否封禁了465或587端口，可通过telnet smtp.gmail.com 465测试是否能正常连接。
• 排查账号状态：登录Gmail网页端，检查账号是否因异常操作被临时限制发送邮件，或是否达到每日发送限额。

四、验证步骤 #

1. 先删除重复的ValidateEmailAddress函数，确保Access能正常编译模块。
2. 替换密码为应用专用密码（开启2步验证后生成）。
3. 测试发送一封简单邮件，根据具体错误提示调整配置。

整理后的完整代码（已修复重复函数+补全参数逻辑） #

Option Compare Database
Option Explicit

Public Function EmailReceiptByGeneric( _
    ByVal strReceipt As String, _
    ByVal Recipient As String, _
    ByVal ToAdd As String, _
    ByVal strProgram As String, _
    ByVal Attachment As String, _
    ByVal strSubject As String, _
    ByVal strMessage As String, _
    ByVal strEmailFROM As String, _
    ByVal strEmailPWD As String, _
    Optional ByVal CC As String) As Boolean

    Dim cdoConfig As Object
    Dim msgOne As Object

On Error GoTo errHandler

EmailReceiptByGeneric = False
    Set cdoConfig = CreateObject("CDO.Configuration")
    With cdoConfig.Fields
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 '可尝试改为587
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strEmailFROM
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strEmailPWD
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
        
        .Update
    End With
    
    Set msgOne = CreateObject("CDO.Message")

    Set msgOne.Configuration = cdoConfig
    
    msgOne.To = ToAdd
    msgOne.FROM = strEmailFROM
    msgOne.Subject = strSubject
    msgOne.htmlBody = strMessage & "<br/>" & "<br/>" & "<br/>" & "<br/>" & _
        strReceipt
    
    '处理附件参数
    If Attachment <> "" Then
        msgOne.AddAttachment Attachment
    End If
    
    '处理抄送参数
    If CC <> "" Then
        msgOne.CC = CC
    End If
    
    msgOne.send
    EmailReceiptByGeneric = True

Cleanup:
    On Error GoTo 0
    On Error Resume Next
    '释放对象
    Set msgOne = Nothing
    Set cdoConfig = Nothing

exitProc:
    Exit Function
        
errHandler:
    EmailReceiptByGeneric = False
    MsgBox prompt:="发送邮件出错 (" & strEmailFROM & "): " & Err.Number & " - " & Err.Description, _
        buttons:=vbCritical + vbOKOnly, title:="邮件发送失败"
    Resume Cleanup
    Resume
End Function

Public Function ValidateEmailAddress(ByVal strEmailAddress As String) As Boolean
    Dim objRegExp As Object
    Dim blnIsValidEmail As Boolean

On Error GoTo errHandler
    strEmailAddress = Trim(strEmailAddress)
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.IgnoreCase = True
    objRegExp.Global = True
    objRegExp.Pattern = "^([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})$"
    blnIsValidEmail = objRegExp.Test(Trim(strEmailAddress))
    ValidateEmailAddress = blnIsValidEmail
 
Cleanup:
    On Error GoTo 0
    On Error Resume Next
    Set objRegExp = Nothing

exitProc:
    Exit Function
        
errHandler:
    ValidateEmailAddress = False
    MsgBox prompt:=Err.Number & ": " & Err.Description, buttons:=vbCritical + vbOKOnly, title:="邮箱验证失败"
    Resume Cleanup
    Resume
End Function

Public Function ValidatePMT(ByVal dblPmtAmt As Double, ByVal dtPmtDate As Date) As Boolean

On Error GoTo errHandler

    If dblPmtAmt = 0 Then
        ValidatePMT = False
        MsgBox prompt:="邮件收据需要填写付款金额。", buttons:=vbExclamation + vbOKOnly, title:="缺少必填付款金额"
        GoTo Cleanup
    ElseIf dtPmtDate = #1/31/2099# Then
        ValidatePMT = False
        MsgBox prompt:="邮件收据需要填写付款日期。", buttons:=vbExclamation + vbOKOnly, title:="缺少必填付款日期"
        GoTo Cleanup
     End If
    ValidatePMT = True
    
Cleanup:
    On Error GoTo 0
    On Error Resume Next

exitProc:
    Exit Function
        
errHandler:
    MsgBox prompt:="意外错误 " & Err.Number & ", " & Err.Description, buttons:=vbExclamation + vbOKOnly, title:="错误"
    Resume Cleanup
    Resume
End Function

内容的提问来源于stack exchange，提问作者Ahoycaptain10234