dvbqp

tenta usar esse codigo 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 = Sheets("Lista_e-mail").Range("d2:d300") 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 = Sheets("E-mail").Range("C33") '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 = Sheets("E-mail").Range("C9") 'O conteudo do Mail .Body = Sheets("E-mail").Range("C13") 'enviar mensagem .Send End With fim: 'Libertar as variaveis Set objOlAppApp = Nothing Set objOlAppMsg = Nothing Set objOlAppAnexo = Nothing Set objOlAppRecip = Nothing MsgBox "E-mail enviado com sucesso!", vbInformation End Sub