如何使用VBA实现Excel满足条件时自动发送Outlook邮件到指定邮箱

原有代码核心问题 #

• 事件过程的局部变量Target无法在Mail_small_Text_Outlook子过程中直接访问，原有代码错误取D列值作为收件人，没有取同行C列的代理商邮箱
• 报价单编号没有正确传入邮件内容，邮件格式不符合中文需求
• 用全局变量传参稳定性差，改为直接传递必要参数给发邮件子过程更可靠

修改后完整代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Dim xRg As Range
    ' 仅处理单个单元格修改场景
    If Target.Cells.Count > 1 Then Exit Sub
    ' 仅监听D2:D1000区域的修改
    Set xRg = Intersect(Range("D2:D1000"), Target)
    If xRg Is Nothing Then Exit Sub
    ' D列数值大于2时触发发件逻辑
    If IsNumeric(Target.Value) And Target.Value > 2 Then
        Dim agentEmail As String, quoteNo As String
        ' 取同行C列邮箱
        agentEmail = Cells(Target.Row, "C").Value
        ' 取同行A列报价单编号，此处列标可根据你实际存储编号的列修改
        quoteNo = Cells(Target.Row, "A").Value
        ' 调用发件子过程传入参数
        Call Mail_small_Text_Outlook(agentEmail, quoteNo)
    End If
End Sub

Sub Mail_small_Text_Outlook(recvEmail As String, quotationNo As String)
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim mailBody As String
    
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    ' 按需求构造正文
    mailBody = "您好！" & vbNewLine & vbNewLine & _
              "您有编号为" & quotationNo & "的待处理报价单"
              
    On Error Resume Next
    With xOutMail
        .To = recvEmail
        .CC = ""
        .BCC = ""
        .Subject = "待处理报价单提醒：" & quotationNo
        .Body = mailBody
        .Display ' 测试阶段用这个预览邮件，确认无误后替换为.Send直接发送
    End With
    On Error GoTo 0
    
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

注意事项 #

• 代码需要放在对应工作表的模块中，不要放在普通模块，否则Worksheet_Change事件不会触发
• 使用前请确保Outlook已完成账号配置且处于登录状态
• 如果报价单编号不是存储在A列，修改quoteNo = Cells(Target.Row, "A").Value中的列标为实际列即可，比如编号在B列就改为"B"

内容的提问来源于stack exchange，提问作者Ahmed Thakaa Al-Mubarak