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.

04
Abr08

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

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 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

 

 

Se tiverem alguma sugestão, está um link abaixo que diz  "comentar", força .... é só clicar e digitar, simples não?

 

 

12 comentários

Comentar post