Ir ao conteúdo
  • Cadastre-se
Felipe Carvalho_748684

RESOLVIDO Modificar macro de envio de e-mail

Recommended Posts

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

Compartilhar este post


Link para o post
Compartilhar em outros sites

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
 

Compartilhar este post


Link para o post
Compartilhar em outros sites

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

Compartilhar este post


Link para o post
Compartilhar em outros sites

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

Compartilhar este post


Link para o post
Compartilhar em outros sites

 

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

 

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.

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora





Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×