Enviar Email com anexo pelo Excel via Outlook - JJoão (03/2003)

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 With
fim:
    'Libertar as variaveis
    Set objOlAppApp = Nothing
    Set objOlAppMsg = Nothing
    Set objOlAppAnexo = Nothing
    Set objOlAppRecip = Nothing
End Sub