Enviar Email com anexos e com assinatura pelo Excel via Outlook
Esta rotina começou por ser um simples tira teimas, isto em 2002, a intenção era demonstrar como seria simples e fácil enviar email com anexos para diversos utilizadores via VBA/Excel. Daí para cá, e principalmente nas ultimas semanas, já sofreu algumas alterações a pedido de alguns visitantes desde blogue. Houve um pedido para colocar assinaturas pré-feitas no outlook e agora o suporte para mais do que 1 anexo.
Tive que reformulei o código para suportar mais do 1 anexo, por isso coloco aqui só as rotinas VBA, que substituem as anteriores, coloco também uma imagem com as celulas que terão as informações necessárias (emails, anexos, etc..) e respectivas localizações, algumas foram alteradas para melhorar a apresentação.
As explicações sobre o código, aquilo que não estiver nas rotinas, encontram nos outros dois posts que coloco aqui os links
- 1 - Enviar Email com anexo pelo Excel via Outlook (rotina anterior)
- 2 - Enviar Email com anexo pelo Excel via Outlook com assinatura (complemento para assinatura)
Mantêm-se a necessidade de estabelecer uma referencia (ligação) ao outlook como explicado 1º post
Area de parametrização, destinatários, tipo de envio (CC, BCC), assinatura e anexos
Código VBA
Option Explicit ' ' http://snippetguy.blogs.sapo.pt ' Sub Enviar_email() Dim enderecos As Range Dim celula As Range Dim anexo As String Dim r As Integer Dim fim Dim enviar Dim objOlAppApp As Outlook.Application Dim objOlAppMsg As Outlook.MailItem Dim objOlAppRecip As Outlook.Recipient Set objOlAppApp = CreateObject("Outlook.Application") Set objOlAppMsg = objOlAppApp.CreateItem(olMailItem) 'Celulas com os endereços Set enderecos = Range("C4:C10") With objOlAppMsg 'Processar endereços para o envio For Each celula In enderecos If celula.Text <> "" And InStr(1, celula.Text, "@") > 0 Then Set objOlAppRecip = .Recipients.Add(celula.Text) 'definir o tipo do destinatario Select Case UCase(celula.Offset(0, 1).Text) Case "CC" objOlAppRecip.Type = olCC Case "BCC" objOlAppRecip.Type = olBCC Case "" objOlAppRecip.Type = olTo End Select End If Next celula 'verificar se existe destinatário(s) If .Recipients.Count = 0 Then GoTo fim 'Anexar ficheiro(s), com o nome e caminho escrito na celula C13 ' 'Para mais do que 1 anexo utilizar ; como separador 'Ex: c:\anexo1.txt;c:\anexo2.txt;c:\anexo3.txt ' anexo = Range("C13") 'testar se existe anexos If Len(anexo) = 0 Then GoTo enviar 'tratar anexos Dim anexos anexos = Split(anexo, ";") Dim i For i = LBound(anexos) To UBound(anexos) 'verificar se o caminho para o anexo é válido If Dir(anexos(i)) = "" Then r = MsgBox("Anexo '" & anexos(i) & _ "'inexistente ou caminho invalido, " & _ "pretende enviar assim mesmo ? ", _ vbYesNo, _ "Erro na localização do anexo") If r <> vbYes Then GoTo fim Else .Attachments.Add anexos(i) End If Next i enviar: 'definir a sua importancia .Importance = olImportanceHigh 'O assunto .Subject = "Envio de Livro - " & Format(Now, "dd-mmm.yyyy hh:mm:ss") 'O conteudo do Mail mais a assinatura (caso exista) .Body = "Envio de livro ......... " & vbCrLf & _ "....Texto a inserir no conteudo do mail.........." & _ vbCrLf & _ Assinatura 'enviar mensagem .Send End Withfim: 'Libertar as variaveis Set objOlAppApp = Nothing Set objOlAppMsg = Nothing Set objOlAppRecip = NothingEnd Sub ' ' Função usada para tratar o pedido de inserção de assinatura ' Function Assinatura() Dim fAssinatura, stAssinatura, stLinha fAssinatura = Environ("APPDATA") & "\Microsoft\Signatures\" & Range("C15") stAssinatura = "" If Dir(fAssinatura) <> "" Then Open fAssinatura For Input As #1 Do While Not EOF(1) Line Input #1, stLinha stAssinatura = stAssinatura & vbCrLf & stLinha Loop Close #1 End If Assinatura = stAssinatura End Function
Se tiverem alguma sugestão, está um link abaixo que diz "comentar", força .... é só clicar e digitar, simples não?