Envio de e-mail com anexos

27/10/2015

Pessoal não absolutamente nada de VBA mas hoje me deparei com anecessidade enviar uma e-mail para varias pessoas como uma mala direta porém terei que enviar com dois anexos, e no e-mail teria logins e senha que seriam dados unicos para cada destinatário, até achei uma planilha em excel com um modolo em vba que faz isso, mas envia apenas um anexo por vez!

abixo estou postando o código aguem sabe posso modificar este código para inserir mais de um anexo no e-mail por vez?

ub Enviar_Email(Dest As String, Copia As String, Nome As String, AnexItem As String)

'declara variaveis
Dim Assunto As String, Msg As String, AnexPath As String

'atribui assunto
Assunto = Range("assunto")

'atribui mensagem
Msg = Range("mensagem")

'atribui caminhos dos anexos
AnexPath = Range("anexos") & "\" & AnexItem

'verifica se o arquivo existe
'Set fs = CreateObject("Scripting.FileSystemObject")
'Set a = fs.fileexists(AnexPath)

'inclui o nome de destinatario na mensagem
Msg = Replace(Msg, "<%Nome%>", Nome)

'inicia objeto de email do Outlook
Dim oApp As Outlook.Application
Dim oMailItem As Outlook.MailItem

Set oApp = CreateObject("Outlook.Application")
Set oMailItem = oApp.CreateItem(olMailItem)

With oMailItem

    .Subject = Assunto
    .Body = Msg
    .To = Dest
    .CC = Copia
    If Dir(AnexPath) <> "" Then .Attachments.Add (AnexPath)
    .Send
    
End With


End Sub

Sub Enviar_Tudo()

x = 2
Do Until Range("A" & x) = ""
    Enviar_Email Range("B" & x), Range("C" & x), Range("A" & x), Range("D" & x)
    x = x + 1
Loop

End Sub

Moisés

Respostas

28/10/2015

Moisés

Alguém me dá uma força ai por favor!!
Responder Citar

28/10/2015

Jothaz

Tem décadas que não programo em VBA, mas dê um olhada aqui:

Anexando arquivos

http://www.hardware.com.br/comunidade/ajuste-email/1041019/
Responder Citar

28/10/2015

Moisés

Jothaz, valeu pelos Links, mas o que preciso é apenas uma maneira de enviar mais um anexo, o código tenho acima envia para vários usuários mas apenas um 1 arquivo como anexo, quero poder enviar mais um arquivo, creio que seja necessário fazer algum loop, mas sei nada de VB
Responder Citar

28/10/2015

Jothaz

Você chegou a analisar os códigos dos links.

No primeiro link no código é criado um array vAnexos (com o range de onde estão os anexos) e depois usa o comando:

vAnexos = Application.GetOpenFilename(Title:="Anexar arquivos", MultiSelect:=True)


Que é justamente para ativar o envio de mais de um anexo.

Infelizmente se os exemplos não lhe ajudaram, sinto muito, mas tenho como sugerir mais nada.

Vamos aguardar outras sugestões e desejo-te boa sorte.
Responder Citar

28/10/2015

Moisés

Blz não não consegui usar isso no meu código!
Responder Citar

29/10/2015

Moisés

Dei uma olhada no que o Jothaz citou mas não consegui inseri-lo meu, alguém poderia me ajudar por favor.
Responder Citar

29/10/2015

Moisés

Pessoal boa Tarde, consegui resolver, agora consigo anexar quantos arquivos quizer, porém o anexo tem que ser igual para todos os usuários.
'Sub Enviar_Email(Dest As String, Copia As String, Nome As String, AnexItem As String)
Sub Enviar_Email(Dest As String, Copia As String, Nome As String, Usuario As String)

'declara variaveis
Dim Assunto As String, Msg As String ', AnexPath As String

'atribui assunto
Assunto = Range("assunto")

'atribui mensagem
Msg = Range("mensagem")

'atribui caminhos dos anexos
'AnexPath = Range("anexos") & "\" & AnexItem



'verifica se o arquivo existe
'Set fs = CreateObject("Scripting.FileSystemObject")
'Set a = fs.fileexists(AnexPath)

'inclui o nome de destinatario na mensagem
Assunto = Replace(Assunto, "<%Nome%>", Nome)
Msg = Replace(Msg, "<%Usuario%>", Usuario)

'inicia objeto de email do Outlook
Dim oApp As Outlook.Application
Dim oMailItem As Outlook.MailItem

Set oApp = CreateObject("Outlook.Application")
Set oMailItem = oApp.CreateItem(olMailItem)

With oMailItem

    .Subject = Assunto
    .Body = Msg
    .To = Dest
    .CC = Copia
    'If Dir(AnexPath) <> "" Then .Attachments.Add (AnexPath)
    .Attachments.Add "C:\Users\NAC\Desktop\anexo1.pdf"
    .Attachments.Add "C:\Users\NAC\Desktop\anexo2.pdf"
    .Send
    
End With


End Sub

Sub Enviar_Tudo()

x = 2
Do Until Range("A" & x) = ""
    Enviar_Email Range("B" & x), Range("C" & x), Range("A" & x), Range("D" & x)
    'Enviar_Email Range("B" & x), Range("C" & x), Range("A" & x), Range("D" & x)
    x = x + 1
Loop

End Sub

Responder Citar