Boa tarde!!!
Segue o código de envio de e-mail que tenho hoje. O que eu preciso é que ele me liste os dados da planilha identificado pelos critérios (if...then, do código abaixo) e envie os e-mails apenas para estes itens identificados. Porém, o que acontece é que ele exibe quantos e-mails eu tenho para enviar através do critério (If...Then, indicada no código) , mas quando vai enviar os e-mails, ele não preserva este critério e envia e-mail para todas as linhas da planilha e não apenas para as linhas que foram identificadas pelo critério (If...Then do código).
Código
Sub FUP()
Dim Maildb As Object
Dim MailDoc As Object
Dim Body As Object
Dim Session As Object
Dim texto As String
Dim rcpt As String
Dim rcptcc As String
Dim subj As String
Dim FUPE As Date
Dim tipo1 As String
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Aviso" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic
FUPE = Date
'linha = ActiveCell.Row - 1
linha = 8
Conta1 = 0
Do While Sheets(2).Cells(linha, 1) <> ""
If Sheets(2).Cells(linha, 5).Value = "Tarea" And Sheets(2).Cells(linha, 14).Value = "Em andamento" Or Sheets(2).Cells(linha, 14).Value = "A iniciar" Then
If Sheets(2).Cells(linha, 22).Value = FUPE Or Sheets(2).Cells(linha, 23).Value = FUPE Or Sheets(2).Cells(linha, 24).Value = FUPE Then
texto = "Buenas, " & vbCrLf & vbCrLf & _
"La tarea descripta abajo está pendiente de termino, " & _
"por favor, finalizar la tarea antes de la fecha fin designada en SGP y enviar las evidencias para el TM del proyecto." & vbCrLf & vbCrLf & _
" Informaciones de la tarea:" & vbCrLf & vbCrLf & _
" Tarea: " & Sheets(2).Cells(linha, 4) & vbCrLf & _
" Descrición: " & Sheets(2).Cells(linha, 7) & vbCrLf & vbCrLf & vbCrLf & _
" -------------------------------------------------------" & vbCrLf & _
" Ejecutor: " & Sheets(2).Cells(linha, 18) & vbCrLf & _
" Fecha inicio: " & Sheets(2).Cells(linha, 11) & vbCrLf & _
" Fecha fin: " & Sheets(2).Cells(linha, 12) & vbCrLf & _
" Atraso(dia): " & Sheets(2).Cells(linha, 13) & vbCrLf & vbCrLf & vbCrLf & _
"Muchas gracias" & vbCrLf & _
"Saludos" & vbCrLf & _
"-----------------------------------" & vbCrLf & _
"Luciano Petrucci"
Conta1 = Conta1 + 1
End If
End If
linha = linha + 1
tipo1 = Sheets(2).Cells(linha, 5)
Msg = Date & " :: Você possuí: " & vbCrLf & _
Conta1 & " alertas de tarefa Em andamento e/ou a iniciar, deseja enviar"
Loop
'Define message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then
'Conta1 = Conta1 + 1
'Start a session of Lotus Notes
Set Session = CreateObject("Lotus.NotesSession")
'This line prompts for password of current ID noted in Notes.INI
'or use below to provide password of the current ID (to avoid Password prompt)
'Call Session.Initialize("<password>")
'Exemplo: Call Session.Initialize("123456")
Call Session.Initialize("123456")
'Open the Mail Database of your Lotus Notes
'Exemplo: Set Maildb = Session.GetDatabase("", "C:\Notes\data\Mail7\lucipe.nsf")
Set Maildb = Session.GetDatabase("", "C:\Notes\data\Mail7\lucipe.nsf")
If Not Maildb.IsOpen = True Then Call Maildb.Open
'Create the Mail Document
Set MailDoc = Maildb.CreateDocument
Call MailDoc.REPLACEITEMVALUE("Form", "Memo")
'Set the Recipient of the mail
rcpt = Sheets(2).Cells(linha, 19)
rcptcc = Sheets(2).Cells(linha, 21)
Call MailDoc.REPLACEITEMVALUE("SendTo", rcpt)
Call MailDoc.REPLACEITEMVALUE("CopyTo", rcptcc)
'Set subject of the mail
subj = Sheets(2).Cells(linha, 2)
subj2 = Sheets(2).Cells(linha, 3)
subj3 = Sheets(2).Cells(linha, 4)
Call MailDoc.REPLACEITEMVALUE("Subject", "[" & subj & " :: " & subj2 & "] " & subj3 & " - " & "Para su acción :: Tarea pendiente")
'Create and set the Body content of the mail
Set Body = MailDoc.CreateRichTextItem("Body")
Call Body.AppendText(texto)
'Example to create an attachment (optional)
'If Sheets(1).Cells(linha, 14) <> "" And Sheets(1).Cells(linha, 13) <> "" Then
' Call Body.AddNewLine(2)
' Call Body.EmbedObject(1454, "", Sheets(1).Cells(linha, 14) & Sheets(1).Cells(linha, 13), "Attachment")
'End If
'If Sheets(1).Cells(linha, 15) <> "" And Sheets(1).Cells(linha, 16) <> "" Then
' Call Body.AddNewLine(4)
' Call Body.EmbedObject(1454, "", Sheets(1).Cells(linha, 16) & Sheets(1).Cells(linha, 15), "Attachment")
'End If
'Example to save the message (optional) in Sent items
MailDoc.SaveMessageOnSend = True
'Send the document
'Gets the mail to appear in the Sent items folder
Call MailDoc.REPLACEITEMVALUE("PostedDate", Now())
Call MailDoc.Send(False)
'Clean Up the Object variables - Recover memory
Set Maildb = Nothing
Set MailDoc = Nothing
Set Body = Nothing
Set Session = Nothing
Else
End If