发送到保存在单元格中的电子邮件地址

Question

我有以下 VBA 代码来发送 Outlook 电子邮件。

应根据“D”列应用的条件发送电子邮件。

如果“D”列的条件为真，则应创建电子邮件并将其发送到“C”列中的电子邮件地址，其中其单元格与“D”列条件的同一行。

除了与将其发送到列“C”中的电子邮件地址相关的代码外，我已经编写了所有代码，该代码位于“D”列条件的同一行中。

Dim xRg As Range
'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
    Set xRg = Intersect(Range("D2:D1000"), Target)
    If xRg Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) And Target.Value > 2 Then
        Call Mail_small_Text_Outlook
    End If
End Sub

Sub Mail_small_Text_Outlook()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Hi there" & vbNewLine & vbNewLine & _
              "You have pending quotation which its number" 
    On Error Resume Next
    With xOutMail
        .To = "Email Address"
        .CC = ""
        .BCC = ""
        .Subject = "send by cell value test"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

Answer 1

您似乎需要将电子邮件发送给 Excel 工作表中指定的收件人。要使其正常工作，您需要从单元格中提取一个值并将其传递给 Mail_small_Text_Outlook 方法：

 Dim xRg As Range
    'Update by Extendoffice 2018/3/7
    Private Sub Worksheet_Change(ByVal Target As Range)
        On Error Resume Next
        If Target.Cells.Count > 1 Then Exit Sub
      Set xRg = Intersect(Range("D2:D1000"), Target)
        If xRg Is Nothing Then Exit Sub
        If IsNumeric(Target.Value) And Target.Value > 2 Then
            Mail_small_Text_Outlook(Target.Cells("C2"))
        End If
    End Sub
    Sub Mail_small_Text_Outlook(Dim value as string)
        Dim xOutApp As Object
        Dim xOutMail As Object
        Dim xMailBody As String
        Set xOutApp = CreateObject("Outlook.Application")
        Set xOutMail = xOutApp.CreateItem(0)
        xMailBody = "Hi there" & vbNewLine & vbNewLine & _
                  "You have pending quotation which its number" 
        On Error Resume Next
        With xOutMail
            .To = value
            .CC = ""
            .BCC = ""
            .Subject = "send by cell value test"
            .Body = xMailBody
            .Display   'or use .Send
        End With
        On Error GoTo 0
        Set xOutMail = Nothing
        Set xOutApp = Nothing
    End Sub

您可以在Mail from Excel with Outlook (Windows) 页面上找到很多示例。特别关注Mail a different file(s) to each person in a range的文章。

Answer 2

基于目标单元格引用另一个单元格。

Target.Offset(0, -1)

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

Dim xRg As Range

Sub Worksheet_Change(ByVal Target As Range)
        
    If Target.Cells.Count > 1 Then Exit Sub
    
    Set xRg = Intersect(Range("D2:D1000"), Target)
    If xRg Is Nothing Then Exit Sub
    
    If IsNumeric(Target.Value) And Target.Value > 2 Then
        Call Mail_small_Text_Outlook(Target.Offset(0, -1).Value)
    End If
    
End Sub


Sub Mail_small_Text_Outlook(valueColC As String)

    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    
    xMailBody = "Hi there" & vbNewLine & vbNewLine & _
      "You have pending quotation which its number"
    
    ' feel free to remove when it immediately precedes With xOutMail
    ' https://excelmacromastery.com/vba-error-handling/#On_Error_Resume_Next
    With xOutMail
        .To = valueColC
        .CC = ""
        .BCC = ""
        .Subject = "send by cell value test"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    
    Set xOutMail = Nothing
    Set xOutApp = Nothing
    
End Sub