Saltar para: Post [1], Comentários [2], Pesquisa e Arquivos [3]

Code Snippets Blog

Pequenas rotinas em vba, vbscript e outras linguagens. Noticias sobre informática, workshops, e outras coisas relacionadas com novas tecnologias.

Code Snippets Blog

Pequenas rotinas em vba, vbscript e outras linguagens. Noticias sobre informática, workshops, e outras coisas relacionadas com novas tecnologias.

12
Abr08

Enviar Email com anexos, assinatura e imagens pelo Excel via Outlook

Mais uma pequena alteração, esta para permitir enviar imagens dentro da mensagem, esta imagem pode ser colocado como background ou simplesmente inseri-la junto do texto.

Para colocar como background pode fazê-lo através do "<body background="cid:imagem.jpg">" ou em tabela no corpo da mensagem, para esta personalização terá que se explorar um pouco o html.

A rotina permite inserir várias imagens, desde que seja escrito o caminho correcto na celula C14, para mais do que uma, deve-se separar com o ; (ponto e virgula)

Foi adicionado "Function recolheImagem(stImagem)" que retira o caminho da imagem quando este já não é necessário.

(Versão anterior e mais pormenores sobre a instalação no post)

Option Explicit
'
' http://snippetguy.blogs.sapo.pt
' Enviar email v3.0
'
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") 'tratar imagens para inserir no email
Dim imagem, arrImagens 'celula onde colocamos a localização da imagem
imagem = Range("C14") If Len(imagem) > 0 Then arrImagens = Split(imagem, ";") imagem = "<p>Imagem</p>" For i = LBound(arrImagens) To UBound(arrImagens) If Dir(arrImagens(i)) <> "" Then .Attachments.Add arrImagens(i) imagem = imagem & _ "<p><img src=""cid:" & _ recolheImagem(arrImagens(i)) & _ """ /></p>" End If Next i End If 'O conteudo do Mail, imagens e assinatura (caso existam)
.HTMLBody = "<html><body>Envio de livro .........<br />" & _ "Texto a inserir no conteudo do mail..........<br />" & _ imagem & "<br />" & Assinatura & "</body></html>" 'enviar mensagem
.Send End With fim: 'Libertar as variaveis
Set objOlAppApp = Nothing Set objOlAppMsg = Nothing Set objOlAppRecip = Nothing End 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 '
' Função que retira o caminho da imagem deixando só o nome desta,
' é usado para inserir a imagem no email.
' Ex: c:\imagens\imagem.jpg
' fica: imagem.jpg
'
Function recolheImagem(stImagem) Dim x, ultimo_x 'vamos buscar só o nome da imagem
x = InStr(1, stImagem, "\") Do ultimo_x = x x = InStr(x + 1, stImagem, "\") Loop Until x = 0 recolheImagem = Mid(stImagem, _ InStr(ultimo_x, stImagem, "\") + 1, _ Len(stImagem)) End Function

9 comentários

Comentar post