使用 Excel VBA 根据特定单元格中的下拉答案发送电子邮件

Question

下面是我让所有经理在回复电子邮件中抄送的代码。

我宁愿将单元格 P2（“选择您的工作区域”）的内容直接抄送电子邮件。
例如“雪营（3-6）”被抄送给 Melissa 的电子邮件地址。

样本表格：

Private Sub CommandButton1_Click()
Dim xOutlookObj As Object
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next
Set Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Set Wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
    Case xlOpenXMLWorkbook:
        xFile = ".xlsx"
        xFormat = xlOpenXMLWorkbook
    Case xlOpenXMLWorkbookMacroEnabled:
        If Wb2.HasVBProject Then
            xFile = ".xlsm"
            xFormat = xlOpenXMLWorkbookMacroEnabled
        Else
            xFile = ".xlsx"
            xFormat = xlOpenXMLWorkbook
        End If
    Case Excel8:
        xFile = ".xls"
        xFormat = Excel8
    Case xlExcel12:
        xFile = ".xlsb"
        xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & "\"
Filename = Wb.Name & Format(Now, "dd-mmm-yy")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & Filename & xFile, FileFormat:=xFormat
With OutlookMail
    .To = "[email protected]"
    .CC = "[email protected];[email protected];[email protected];" & Range("k7").Value
    .BCC = ""
    .Subject = "2024-25 Schedule - " & Range("E3").Value
    .Body = "Please be sure to save a copy of your schedule for reference." & vbNewLine & _
      vbNewLine & _
      "You can reach out to your Core Area manager after October 1st:" & vbNewLine & _
      "**Snow Camp - [email protected]" & vbNewLine & _
      "**Mountain Camp - [email protected]" & vbNewLine & _
      "**Privates & Adults - [email protected]" & vbNewLine & _
      vbNewLine & _
      "Thank you for submitting your schedule. Refresher weekend is November 2nd & 3rd. We hope to see you there!" & vbNewLine & _
      vbNewLine & _
      "***Think Snow***"
    On Error Resume Next
    .Attachments.Add Wb2.FullName
    .Display   'or use .Send
End With
Wb2.Close
Kill FilePath & Filename & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
End Sub

我尝试在“On Error Resume Next”行下方添加代码，但出现错误。我试图触发一封发送给梅丽莎的电子邮件，但也将员工的姓氏添加到电子邮件主题行中。如果可以通过其他方式触发电子邮件，我很乐意删除“提交”按钮。

Dim xRg As Range
Private Sub Worksheet_Change(Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
    Set xRg = Intersect(Range("P2"), Target)
    If xRg Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) And Target.Value > "Snow Camp (3-6)"Then
        Call Mail_small_Text_Outlook
        With OutlookMail
            .To = "[email protected]"
            .CC = "[email protected];" & Range("k7").Value
            .BCC = ""
            .Subject = "2024-25 Schedule - " & Range("E3").Value

Answer 1

您可以使用

Select Case

语句根据单元格 P2 的值动态设置

.CC

属性。您将在配置电子邮件属性（例如，

.To

、

.CC

等）之前插入此逻辑。现在，要根据单元格更改触发电子邮件，我将使用不同的策略。

首先，让我们修复

CommandButton1_Click

过程，以根据单元格 P2 中的下拉菜单动态设置 CC。假设单元格 P2 包含工作区域的名称（例如“Snow Camp (3-6)”），您可以执行以下操作：

Private Sub CommandButton1_Click()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim xMailBody As String
    Dim ccEmail As String
    
    ' Your existing setup code for the workbook, worksheet, etc.
    
    ' Determine the CC email based on the dropdown in P2
    Select Case Range("P2").Value
        Case "Snow Camp (3-6)"
            ccEmail = "[email protected]"
        Case "Mountain Camp"
            ccEmail = "[email protected]"
        Case "Privates & Adults"
            ccEmail = "[email protected]"
        Case Else
            ccEmail = "" ' Default or a fallback email
    End Select
    
    ' Your existing code to create Outlook objects
    
    With OutlookMail
        .To = "[email protected]"
        .CC = ccEmail & ";" & Range("k7").Value ' Use the dynamically determined CC
        ' Your existing code for BCC, Subject, Body, etc.
    End With
    
    ' Your existing code to finalize the email and clean up
End Sub

要根据特定单元格（如 P2）的更改触发电子邮件，您通常会在工作表的代码模块中使用

Worksheet_Change

事件，而不是在与按钮单击事件相同的代码中使用。这种方法需要仔细考虑，特别是在用户体验和无意发送电子邮件的可能性方面。这是一个如何开始的简化示例：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("P2")) Is Nothing Then
        ' Call your mail function here, or place a simplified version of the mail sending code directly here
        ' Be cautious with this to prevent accidental email sends
    End If
End Sub

如果不仔细管理，基于单元格更改的自动电子邮件发送可能会导致大量意外电子邮件。在自动发送电子邮件之前，请考虑添加额外的检查或确认。

版主请注意：我使用 Typora Markdown 编辑器编辑我的帖子，然后复制并粘贴到此处。别再认为我不是人了。这真是令人沮丧。

Answer 2

这将根据 P2 中的条目确定电子邮件地址和

.Body

文本。

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Private Sub CommandButton1_Click()

'Dim xOutlookObj As Object
'Dim xOutApp As Object
Dim OutlookApp As Object
Dim OutlookMail As Object

' Commonly seen but appropriate in less than a miniscule number of cases.
'On Error Resume Next

Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)

Dim ccText As String
Dim bodyText As String

With OutlookMail

    .To = "[email protected]"
    
    ' InStr is case sensitive.
    ' LCase is one possibility.
    ' Likely unnecessary with a dropdown.
    
    If InStr(LCase(Range("P2").Value), LCase("Snow")) Then
        ccText = "[email protected]"
        bodyText = "Snow Camp - " & ccText
        
    ElseIf InStr(LCase(Range("P2").Value), LCase("Mountain")) Then
        ccText = "[email protected]"
        bodyText = "Mountain Camp - " & ccText
        
    ElseIf InStr(LCase(Range("P2").Value), LCase("Privates")) Then
        ccText = "[email protected]"
        bodyText = "Privates & Adults - " & ccText
    
    Else
        Debug.Print "No match." & vbCr & "P2 Value: " & Range("P2").Value
        MsgBox "No match." & vbCr & vbCr & "P2 Value: " & Range("P2").Value
        GoTo cleanup
        
    End If
    
    .CC = ccText & ";" & Range("k7").Value
    .BCC = ""
    .Subject = "2024-25 Schedule - " & Range("E3").Value
    .Body = "Please be sure to save a copy of your schedule for reference." & vbNewLine & _
      vbNewLine & _
      "You can reach out to your Core Area manager after October 1st:" & vbNewLine & _
      bodyText & vbNewLine & _
      "Thank you for submitting your schedule. Refresher weekend is November 2nd & 3rd. We hope to see you there!" & vbNewLine & _
      vbNewLine & _
      "***Think Snow***"
      
    .Display
End With

cleanup:
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing

End Sub

Worksheet_Change

不合适，会有很多无意中创建的电子邮件。