Modificar macro de envio de e-mail

[Felipe Carvalho_748684]

Bom dia pessoal,

 

Tenho uma planilha de follow-up de pedidos com um VBA para registro de modificação de células com data e envio de e-mail automático pelo Outlook.

Hoje ela funciona assim:

 

Modifico a coluna B, C e D, a data vai para a E, F e G respectivamente.

Quando coloco o X e dou ENTER na coluna B, um e-mail aparece na tela (só com outlook). Esse e-mail pode ser enviado sem abrir a tela modificando um detalhe nela.

 

O que quero fazer é que na coluna C e D também envie e-mails. E que sejam independentes, o primeiro X (a primeira cobrança) vou fazer um aviso normal, a segunda um e-mail mais forte e a terceira um aviso de cancelamento.

 

A Macro está abaixo e um modelo da planilha (não é a original mas pode ser vista) está anexado.

 

Desde já obrigado.

 

 

Private Sub Worksheet_Change(ByVal Target As Range)

 If Target.Column = 2 Then Cells(Target.Row, 5) = Date
 If Target.Column = 3 Then Cells(Target.Row, 6) = Date
 If Target.Column = 4 Then Cells(Target.Row, 7) = Date
 
    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 = "$B$" & linha Then

        If Plan1.Cells(linha, 6) = "Concluído" Then
            
        End If

        With OutMail
            .To = Plan1.Cells(linha, 1)
            .CC = ""
            .BCC = ""
            .Subject = "Título do email"
            .Body = "Prezado(a) " & Plan1.Cells(linha, 1) & "," & vbCrLf & vbCrLf & _
                    "A O.S. " & Plan1.Cells(linha, 7) & " aberta em " & _
                    Plan1.Cells(linha, 2) & " foi concluída." & vbCrLf & _
                    " Veja informações abaixo:" & vbCrLf & _
                    "    Status: " & Plan1.Cells(linha, 6) & vbCrLf & _
                    "    Ação tomada: " & Plan1.Cells(linha, 5) & vbCrLf & vbCrLf & _
                    "Atenciosamente," & vbCrLf & _
                    "Help Desk"
            .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

 

Modelo - Follow-up.zip

[Felipe Carvalho_748684]

Consegui, o código ficou bem grande, mas está funcionando:

 

Private Sub Worksheet_Change(ByVal Target As Range)

 If Target.Column = 2 Then Cells(Target.Row, 5) = Date
 If Target.Column = 3 Then Cells(Target.Row, 6) = Date
 If Target.Column = 4 Then Cells(Target.Row, 7) = Date
 
    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 = "$B$" & linha Then
    If Plan1.Cells(linha, 2) = "X" Then
            
        End If

        With OutMail
            .To = Plan1.Cells(linha, 1)
            .CC = ""
            .BCC = ""
            .Subject = "Título do email"
            .Body = "Prezado(a) " & Plan1.Cells(linha, 1) & "," & vbCrLf & vbCrLf & _
                    "A O.S. " & Plan1.Cells(linha, 7) & " aberta em " & _
                    Plan1.Cells(linha, 2) & " foi concluída." & vbCrLf & _
                    " Veja informações abaixo:" & vbCrLf & _
                    "    Status: " & Plan1.Cells(linha, 6) & vbCrLf & _
                    "    Ação tomada: " & Plan1.Cells(linha, 5) & vbCrLf & vbCrLf & _
                    "Atenciosamente," & vbCrLf & _
                    "Help Desk"
            .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
    
    linha = ActiveCell.Row - 1
    If Target.Address = "$C$" & linha Then
    If Plan1.Cells(linha, 2) = "X" Then
            
        End If

        With OutMail
            .To = Plan1.Cells(linha, 1)
            .CC = ""
            .BCC = ""
            .Subject = "Título do email"
            .Body = "Prezado(a) " & Plan1.Cells(linha, 1) & "," & vbCrLf & vbCrLf & _
                    "A O.S. " & Plan1.Cells(linha, 7) & " aberta em " & _
                    Plan1.Cells(linha, 2) & " foi concluída." & vbCrLf & _
                    " Veja informações abaixo:" & vbCrLf & _
                    "    Status: " & Plan1.Cells(linha, 6) & vbCrLf & _
                    "    Ação tomada: " & Plan1.Cells(linha, 5) & vbCrLf & vbCrLf & _
                    "Atenciosamente," & vbCrLf & _
                    "Help Desk"
            .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
    
      linha = ActiveCell.Row - 1
    If Target.Address = "$D$" & linha Then
    If Plan1.Cells(linha, 2) = "X" Then
            
        End If

        With OutMail
            .To = Plan1.Cells(linha, 1)
            .CC = ""
            .BCC = ""
            .Subject = "Título do email"
            .Body = "Prezado(a) " & Plan1.Cells(linha, 1) & "," & vbCrLf & vbCrLf & _
                    "A O.S. " & Plan1.Cells(linha, 7) & " aberta em " & _
                    Plan1.Cells(linha, 2) & " foi concluída." & vbCrLf & _
                    " Veja informações abaixo:" & vbCrLf & _
                    "    Status: " & Plan1.Cells(linha, 6) & vbCrLf & _
                    "    Ação tomada: " & Plan1.Cells(linha, 5) & vbCrLf & vbCrLf & _
                    "Atenciosamente," & vbCrLf & _
                    "Help Desk"
            .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
 

[minoso]

Não esqueça de marcar o post como 'resolvido' para encerrar o tópico. Obrigado

[ScientiaArca]

Oi Felipe!

Notei que você envia os e-mails um a um, é isso mesmo?

Não seria melhor se você marcasse todas as linhas para enviar e-mail e depois disparasse de uma vez só?

 

O código abaixo faz isso, basta você passar os parâmetros necessários.

Ou faça download da planilha para usar como modelo!

Sub Enviar_Email(Dest As String, Copia As String, Nome As String, AnexItem As String) 'declara variaveisDim Assunto As String, Msg As String, AnexPath As String 'atribui assuntoAssunto = Range("assunto") 'atribui mensagemMsg = Range("mensagem") 'atribui caminhos dos anexosAnexPath = Range("anexos") & "\" & AnexItem 'verifica se o arquivo existe'Set fs = CreateObject("Scripting.FileSystemObject")'Set a = fs.fileexists(AnexPath) 'inclui o nome de destinatario na mensagemMsg = Replace(Msg, "<%Nome%>", Nome) 'inicia objeto de email do OutlookDim oApp As Outlook.ApplicationDim oMailItem As Outlook.MailItem Set oApp = CreateObject("Outlook.Application")Set oMailItem = oApp.CreateItem(olMailItem) With oMailItem .Subject = Assunto.Body = Msg.To = Dest.CC = CopiaIf Dir(AnexPath) <> "" Then .Attachments.Add (AnexPath).Send End With End Sub Sub Enviar_Tudo() x = 2Do Until Range("A" & x) = ""Enviar_Email Range("B" & x), Range("C" & x), Range("A" & x), Range("D" & x)x = x + 1Loop End Sub

Abraços

http://scientiaarca.besaba.com/wordpress/wp-content/uploads/2014/12/Emails.xlsm

[Felipe Carvalho_748684]

 

Oi Felipe!

Notei que você envia os e-mails um a um, é isso mesmo?

Não seria melhor se você marcasse todas as linhas para enviar e-mail e depois disparasse de uma vez só?

 

O código abaixo faz isso, basta você passar os parâmetros necessários.

Ou faça download da planilha para usar como modelo!

Sub Enviar_Email(Dest As String, Copia As String, Nome As String, AnexItem As String) 'declara variaveisDim Assunto As String, Msg As String, AnexPath As String 'atribui assuntoAssunto = Range("assunto") 'atribui mensagemMsg = Range("mensagem") 'atribui caminhos dos anexosAnexPath = Range("anexos") & "\" & AnexItem 'verifica se o arquivo existe'Set fs = CreateObject("Scripting.FileSystemObject")'Set a = fs.fileexists(AnexPath) 'inclui o nome de destinatario na mensagemMsg = Replace(Msg, "<%Nome%>", Nome) 'inicia objeto de email do OutlookDim oApp As Outlook.ApplicationDim oMailItem As Outlook.MailItem Set oApp = CreateObject("Outlook.Application")Set oMailItem = oApp.CreateItem(olMailItem) With oMailItem .Subject = Assunto.Body = Msg.To = Dest.CC = CopiaIf Dir(AnexPath) <> "" Then .Attachments.Add (AnexPath).Send End With End Sub Sub Enviar_Tudo() x = 2Do Until Range("A" & x) = ""Enviar_Email Range("B" & x), Range("C" & x), Range("A" & x), Range("D" & x)x = x + 1Loop End Sub

Abraços

http://scientiaarca.besaba.com/wordpress/wp-content/uploads/2014/12/Emails.xlsm

 

Isso, na minha macro eu vou verificando, digito X e vai enviando. Sem abrir tela no Outlook.

A escolha foi assim porque é necessaria uma avaliação no follow-up. obrigatóriamente tem que ser semi-automatico.

 

Mas obrigado, fica a dica para uma melhoria em outro caso.