Saltar para: Posts [1], Pesquisa [2]

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

 

 

30
Dez07

Um timer em VBA

Um timer para execução de macros, para definir o tempo de intervalo é só colocar em minutos o equivalente em segundos que se pretender.


Colocar num modulo:

Dim Alarme
Const IntervaloSegundos = 5 * 60 ' 5 minutos de intervalo

Sub Iniciar()
    Alarme  =  Now  +  TimeSerial(0, 0,  IntervaloSegundos)
    Application.OnTime EarliestTime:=Alarme, _
                       procedure:="Macro1", _
                       schedule:=True
End Sub

Sub Macro1()
   'As suas rotinas
    MsgBox "Olá!!! voltarei pelas " & Format(Alarme, "hh:mm:ss"), _
            vbInformation, "Timer em Vba"
    Call Iniciar
End Sub

Sub Parar()
    On Error Resume Next
    Application.OnTime EarliestTime:=Alarme, _
                       procedure:="Macro1", _
                       schedule:=False
End Sub 

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