Enviar VARIOS anexos para o mesmo email

Visual Basic for Aplication e macros no Excel.
Regras do fórum
Sua dúvida foi respondida? Marque como RESOLVIDO em seus tópicos, usando o botão com marca verde. Imagem

Enviar VARIOS anexos para o mesmo email

Mensagempor JokerPot » Qua Jan 17, 2018 9:56 am

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.


Código: Selecionar todos
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:\Users\XXXXXXX\Desktop\Calendario\11.Novembro\Novembro.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:\Users\XXXXXX\Desktop\Calendario\Outubro.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
Você não está autorizado a ver ou baixar esse anexo.
JokerPot
Membro
Membro
 
Mensagens: 123
Registrado em: Seg Jul 21, 2014 4:30 pm
Has thanked: 25 times
Have thanks: 7 times

{ SO_SELECT }

Re: Enviar VARIOS anexos para o mesmo email

Mensagempor alexandrevba » Qua Jan 17, 2018 12:49 pm

Boa tarde!!

Já tentou algo assim?
Código: Selecionar todos
Dim files As Variant, file As Variant
files = Split(filepath, ",")
For Each file In files
    .attachments.Add file
Next

Favor adaptar!!!
Att
Espero ter Ajudado.
Se a mensagem foi util Favor Clicar na mãozinha.
Quando necessário, lembre se de marcar o tópico como [RESOLVIDO].
Avatar do usuário
alexandrevba
Membro
Membro
 
Mensagens: 9273
Registrado em: Dom Jul 03, 2011 7:45 pm
Localização: Serra - ES
Has thanked: 0 time
Have thanks: 2667 times

Re: Enviar VARIOS anexos para o mesmo email

Mensagempor JokerPot » Qui Jan 18, 2018 3:19 pm

alexandrevba escreveu:Boa tarde!!

Já tentou algo assim?
Código: Selecionar todos
Dim files As Variant, file As Variant
files = Split(filepath, ",")
For Each file In files
    .attachments.Add file
Next

Favor adaptar!!!
Att

alexandrevba boa tarde!
Infelizmente nao deu certo. A rotina passa direto e finaliza sem fazer nada.
Existe alguma outra possibilidade?

Abraços.
JokerPot
Membro
Membro
 
Mensagens: 123
Registrado em: Seg Jul 21, 2014 4:30 pm
Has thanked: 25 times
Have thanks: 7 times

Re: Enviar VARIOS anexos para o mesmo email

Mensagempor alexandrevba » Qua Jan 31, 2018 7:36 am

Bom dia!!

No meu teste eu usei o outlook, não tive problema.

Talvez eu tenha entendido errado.

Vamos ver se mais alguém possa ajudar.

Att
Espero ter Ajudado.
Se a mensagem foi util Favor Clicar na mãozinha.
Quando necessário, lembre se de marcar o tópico como [RESOLVIDO].
Avatar do usuário
alexandrevba
Membro
Membro
 
Mensagens: 9273
Registrado em: Dom Jul 03, 2011 7:45 pm
Localização: Serra - ES
Has thanked: 0 time
Have thanks: 2667 times


Voltar para VBA & Macros

Quem está online

Usuários navegando neste fórum: Nenhum usuário registrado e 5 visitantes