VBA Outlook 发送到保存在单元格中的电子邮件

Question

I have the below VBA code to automatically send outlook email. the email will be send based on the condition applied on column "D" , so if the condition is true on Column "D" , The email will be automatically created and send it To email in Column "C" where its cell within the same row of the condition on column "D" .

I have written all the codes except the code related to the part " send it To email in Column "C" where its cell within the same row of the condition on column "D" " , so please revise my code and help me

    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

It seems you need to send the email to a recipient specified in the Excel sheet. To get this working you need to extract a value from the cell and pass it to the Mail_small_Text_Outlook method:

 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

You may find a lot of samples on the Mail from Excel with Outlook (Windows) page. Pay special attention to the Mail a different file(s) to each person in a range article.

Answer 2

To reference another cell based on a target cell.

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