Macro - enviar e-mail com anexo pelo excel

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 e-mail - " & Format(Now, "dd-mmm.yyyy hh:mm:ss") 'O conteudo do Mail .Body = "Envio de e-mail ......... "