Envio automático de e-mail para participantes de plano de ação

Question

Olá

Sou responsável pelos planos de ação das não-conformidades da empresa. Diariamente verifico em uma planilha eletrônica do excel as pendências e envio e-mails aos responsáveis cobrando-os as suas ações. Atualmente existem muitos itens nos planos e gasto muito tempo enviando e-mails.
Esta planilha possui 4 colunas. A primeira com a descrição da ação, a segunda com o nome do responsável, a terceira com o prazo para o comprimento da açào, e a quarta com a data de conclusão da ação.
Presciso automatizar este processo da seguinte forma. Diariamente enviar e-mails para os respnosáveis das ações, informando a descrição da ação, o prazo para o cumprimento e se a realização esta atrazada ou não.
Caso alguem possa me ajudar ficarei muito grato.

Answer 1

Bom dia Edivan.

Você não pode mandar a planilha anexada para todos os responsáveis pela execução do plano de ação.??

Se puder, você pode utilizar esse código.

Sub Mail_Outlook_Express()
    Dim Recipient As String, Subj As String, HLink As String
    Dim Recipientcc As String, Recipientbcc As String
    Dim msg As String
    Dim Arq As String
    

'Aqui coloca a célula onde deve estar o nome do arquivo à ser enviado
Arq = Sheets("Plan1").Range("A1").Text

'Aqui cria o arquivo temporário na unidade C:\ (ou outro caminho de sua preferencia)
ThisWorkbook.SaveCopyAs Filename:="C:\" & Arq & ".xls"
        
    Recipient = "[e-mail];[e-mail]"
    Recipientcc = "[e-mail];[e-mail]"
    Recipientbcc = ""
    Subj = "Pedido referente a semana 10"
    msg = "Affonso, bom dia!!!" & vbNewLine & vbNewLine & _
          "Favor enviar para (valor de A1 ou o dia seguinte) o que segue abaixo:"
          
    msg = WorksheetFunction.Substitute(msg, vbNewLine, "%0D%0A")
    HLink = "mailto:" & Recipient & "?" & "cc=" & Recipientcc _
          & "&" & "bcc=" & Recipientbcc & "&"
    HLink = HLink & "subject=" & Subj & "&"
    HLink = HLink & "body=" & msg
    ThisWorkbook.FollowHyperlink (HLink)

'Aqui anexa o arquivo e envia o email
With Application
    .Wait (Now + TimeValue("0:00:01"))
    .SendKeys "%i", Wait = True
    .SendKeys "~", Wait = True
    .SendKeys "C:\" & Arq & ".xls", Wait = True
    .SendKeys "~", Wait = True 
    .SendKeys "%s", Wait = True
End With
    
'Aqui apaga o arquivo temporário
Application.Wait (Now + TimeValue("0:00:05"))
Kill "C:\" & Arq & ".xls"

End Sub

Mais para isso, você tem que estar utilizando o Outlook express.

---

...