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.

30
Dez07

Enviar Email com anexo pelo Excel via Outlook


Observação: Post colocado em 04/04/2008 com rotinas actualizadas
http://snippetguy.blogs.sapo.pt/13040.html

 

 

Macro que envia uma mensagem e um anexo em conjunto com o Outlook para um ou mais
endereços de email.

Num livro (workbook) novo faça uma ligação ao Outlook indo a "References" no menu "Tools" do Editor do VBA e marque :

Numa folha mantendo a localização tal e qual como mostrado na figura abaixo, da C4 à C10 os endereços dos destinatários, na coluna D o tipo de envio se CC, BCC ou se é o titular, neste
ultimo caso não se escreve nada. Na C13 a localização do Anexo.

No editor do VBA insira um modulo e cole a macro abaixo, ligando esta ao botão na folha já feita (figura acima). O botão pode ser inserido através da barra de ferramentas "Formulários"

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
    Dim objOlAppAnexo As Outlook.Attachment

    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
If .Recipients.Count = 0 Then GoTo fim 'Anexar ficheiro, com o nome e caminho escrito na celula C13
anexo = Range("C13") 'verificar se o caminho para o anexo é válido
If Dir(anexo) = "" Then r = MsgBox("Anexo inexistente ou caminho invalido, " & _ "pretende enviar assim mesmo ? ", _ vbYesNo, _ "Erro de anexo") If r = vbYes Then GoTo enviar Else GoTo fim End If Set objOlAppAnexo = .Attachments.Add(anexo) 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
.Body = "Envio de livro ......... " & vbCrLf & _ "....Texto a inserir no conteudo do mail.........." & vbCrLf 'enviar mensagem
.Send End Withfim: 'Libertar as variaveis
Set objOlAppApp = Nothing Set objOlAppMsg = Nothing Set objOlAppAnexo = Nothing Set objOlAppRecip = NothingEnd Sub


Fonte: http://jjoao2k.no.sapo.pt

 

Acrescentar assinatura ver aqui

 

Observação: Post colocado em 04/04/2008 com rotinas actualizadas http://snippetguy.blogs.sapo.pt/13040.html

 

15 comentários

Comentar post