Bom Dia!
Pessoal, tenho uma rotina que seleciona e envia por email arquivos através de uma planilha.
Hoje essa rotina envia 1 arquivo por email independente se o destinatário é o mesmo para arquivos diferentes.
O que eu gostaria de implementar é de enviar VARIOS anexos na medida em que o destinatário seja o mesmo afim de evitar vários envios de e-mails ao mesmo destinatário com anexos diferentes.
Conseguem me ajudar?
Abraços.
Sub EMAILS()
Application.ScreenUpdating = False
Sheets("DADOS").Select
Cells(2, 2).Select
ActiveSheet.Paste
Range("A1:B1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Range("$A$1:$B$1048576").RemoveDuplicates Columns:=1, Header:=xlYes
Dim Pergunta As Variant
Pergunta = MsgBox("O Outlook está aberto?", 4 + 32, "E-mail")
If Pergunta = vbNo Then
MsgBox "Abra o Outlook para comandar a exportação dos dados", vbOKOnly, "Envio"
Exit Sub
End
End If
Dim olapp As Object
Dim oitem As Object
x_CAMINHO = Sheets("PARAMETROS").Range("$H$3").Value & ""
ASSUNTO = Sheets("PARAMETROS").Range("$K$2").Value
MENSAGEM_1 = Sheets("PARAMETROS").Range("$K$4").Value
MENSAGEM_2 = Sheets("PARAMETROS").Range("$K$5").Value
DATA_1 = Sheets("PARAMETROS").Range("$K$6").Value
MENSAGEM_3 = Sheets("PARAMETROS").Range("$K$7").Value
DATA_2 = Sheets("PARAMETROS").Range("$K$8").Value
MENSAGEM_4 = Sheets("PARAMETROS").Range("$K$9").Value
MENSAGEM_5 = Sheets("PARAMETROS").Range("$K$10").Value
MENSAGEM_6 = Sheets("PARAMETROS").Range("$K$11").Value
MENSAGEM_7 = Sheets("PARAMETROS").Range("$K$12").Value
MENSAGEM_8 = Sheets("PARAMETROS").Range("$K$13").Value
'IMAGEM = Sheets("PARAMETROS").Range("$K$49").Select
Sheets("DADOS").Select
ULTIMA_LINHA = Sheets("DADOS").Range("A1048576").End(xlUp).Row
For n_linha = 2 To ULTIMA_LINHA
x_ARQUIVO = "FORECAST - " & Cells(n_linha, 1).Value & ".xlsm"
X_EMAIL = Cells(n_linha, 2).Value
'Workbooks.Open Filename:=(x_CAMINHO & "" & x_ARQUIVO)
Set olapp = CreateObject("Outlook.Application")
Set oitem = olapp.CreateItem(0)
With oitem
.Subject = ASSUNTO & " " & DATA_2
.To = X_EMAIL
.CC = X_EMAIL
.Attachments.Add "C:UsersXXXXXXXDesktopCalendario11.NovembroNovembro.png", olByReference, 1
.HTMLBody = _
"<HTML>" & vbNewLine & _
"<BODY style=font-size:10pt;font-family:Century Gothic> " & vbNewLine & _
"<font color=""black""> " & MENSAGEM_1 & "<P>" & vbNewLine & _
"<font color=""black""> " & MENSAGEM_2 & "</font>" & "<font color=""red""> " & DATA_1 & "<P>" & vbNewLine & _
"<font color=""black""> " & MENSAGEM_3 & "</font>" & "<font color=""red""> " & DATA_2 & "<P>" & vbNewLine & _
"<font color=""black""> " & MENSAGEM_4 & "</font>" & "<font color=""red""> " & MENSAGEM_5 & "</font>" & "<font color=""black""> " & MENSAGEM_6 & "<P>" & vbNewLine & _
"<font color=""black""> " & MENSAGEM_7 & "<P>" & vbNewLine & _
"<font color=""black""> " & MENSAGEM_8 & "<P>" & vbNewLine & _
"</BODY>" & vbNewLine & _
"<img border='0' src='C:UsersXXXXXXDesktopCalendarioOutubro.jpg' width='610' height='148'>"
' "</HTML>"
' .Attachments.Add ActiveWorkbook.FullName
.Attachments.Add (x_CAMINHO & x_ARQUIVO)
.SEND
End With
' Application.DisplayAlerts = False
' ActiveWorkbook.Close
' Application.DisplayAlerts = True
Next
MsgBox "Envio Efetuado.", vbOKOnly, "Envio"
' ActiveWindow.Close
Sheets("forecast").Select
Range("$B$5").Select
End Sub
Postado : 17/01/2018 7:56 am