Guru do Excel e Power BI

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim texto As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    linha = ActiveCell.Row - 1
    If Target.Address = "$H$" & linha Then

        If Plan1.Cells(linha, 8) = "Concluído" Then
            texto = "Prezado(a) " & Plan1.Cells(linha, 4) & "," & vbCrLf & vbCrLf & _
                    "a) Sua amostra está disponível para retirada aqui no LRAC; por favor, informe o número de seu pedido (" & Plan1.Cells(linha, 1) & ") para retirada da amostra." & vbCrLf & vbCrLf & _
                    "b) Segue link com o mapa para localização do laboratório." & vbCrLf & _
                    "http://www.feq.unicamp.br/index.php/lrac2/como-chegar-lrac" & vbCrLf & vbCrLf & _
                    "Atenciosamente,"
        End If

        With OutMail
            .To = Plan1.Cells(linha, 7)
            .CC = ""
            .BCC = ""
            .Subject = "Título do email"
            .Body = texto
            .Display   'Utilize Send para enviar o email sem abrir o Outlook
        End With
        On Error GoTo 0

        Set OutMail = Nothing
        Set OutApp = Nothing
    End If
End Sub

Sub Mail_Outlook_With_Signature_Html_1()
' Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "<H3><B>Prezado(a)</B></H3>" & "," & _
              "Please visit this website to download the new version.<br>" & _
              "Let me know if you have problems.<br>" & _
              "<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
              "<br><br><B>Thank you</B>"

    On Error Resume Next

    With OutMail
        .Display
        .To = "Plan1.Cells(linha, 7)"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = strbody & "<br>" & .HTMLBody
        .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim texto As String
Dim strbody As String 'Adicionar assinatura

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'Adicionar assinatura
strbody = "<H3><B>Prezado(a)</B></H3>" & "," & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
"<br><br><B>Thank you</B>"


linha = ActiveCell.Row - 1
If Target.Address = "$H$" & linha Then

If Plan1.Cells(linha, 8) = "Concluído" Then
texto = "Prezado(a) " & Plan1.Cells(linha, 4) & "," & vbCrLf & vbCrLf & _
"a) Sua amostra está disponível para retirada aqui no LRAC; por favor, informe o número de seu pedido (" & Plan1.Cells(linha, 1) & ") para retirada da amostra." & vbCrLf & vbCrLf & _
"b) Segue link com o mapa para localização do laboratório." & vbCrLf & _
"http://www.feq.unicamp.br/index.php/lrac2/como-chegar-lrac" & vbCrLf & vbCrLf & _
"Atenciosamente,"
End If

With OutMail
    .To = Plan1.Cells(linha, 7)
    .CC = ""
    .BCC = ""
    .Subject = "Título do email"
    .Body = texto
    .Display 'Utilize Send para enviar o email sem abrir o Outlook
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End If
End Sub