none
[Macro que gere e-mails] - Problemas com o loop RRS feed

  • Pergunta

  • Pessoal, bom dia.

    Estou criando uma macro que gere e-mails e envie para os clientes. No e-mail além do endereço de cada pessoa, contém assunto, um corpo de e-mail e um relatório em anexo. Acontece que quando eu rodo para um caso, a macro executa perfeitamente, até mesmo para dois casos ao mesmo tempo. No entanto, quando eu coloco um loop para gerar a partir de 3 e-mails ele executa, mas da problema no corpo do e-mail. Acontece que alguns e-mails fica com o que tem escrito no corpo do e-mails repetido, enquanto que outros ficam sem nada, ou seja a macro copia várias vezes o corpo em apenas um e-mail, e consequentemente outros ficam sem nada, visto que o corpo de e-mail deles foram parar em outros e-mails.

    Já tentei de tudo, até mesmo colocando um delay para os e-mails serem criados mais devagar ou até mesmo reparti em várias macros para a mesma gerar individualmente cada e-mail, mas não obtive sucesso. 

    Notei que a macro deixa a "parte do corpo do e-mail" por último. É como se ela gerasse todos os e-mails e só depois começasse colocar o corpo de e-mails. Então ela não consegue colocar em todos, por esse motivo acontece de um ficar com varios corpos de e-mails e outros sem nada. Por gentileza, alguem poderia me ajudar? Segue meu cpodigo:

    Sub chamar()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Sheets("Capa").Select

    For i = 1 To 20

    Range("r8").Value = i

    Call Teste

    Next

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    End Sub

    Sub Teste()


    JanelaEmail = ActiveWindow.Caption
    Sheets("Capa").Select
    Range("a15:i42").Select

    Dim rng As Range
    Dim sAssunto As Variant
    Dim sPara As Variant
    Dim sCopia As Variant
    Dim sAnexo1 As Variant
    Dim sAnexo2 As Variant
    Dim sAnexo3 As Variant
    Dim sAnexo4 As Variant
    Dim sCorpo As String
    Dim Assinatura As Variant


    Dim appOutLook As New Outlook.Application 
    Dim NovoEmail As Outlook.MailItem
    Set NovoEmail = appOutLook.CreateItem(olMailItem)

    Sheets("Capa").Select

    Set rng = Selection
    rng.Copy


    sPara = Range("a2").Value
    sCopia = Range("a4").Value
    sAssunto = Range("a6").Value

    NovoEmail.Subject = sAssunto
    NovoEmail.To = sPara
    NovoEmail.CC = sCopia


    If Range("V1").Value = 2 Or Range("V1").Value = 4 Then

    sAnexo1 = Range("a8").Value
    NovoEmail.Attachments.Add sAnexo1

    sAnexo2 = Range("a10").Value
    NovoEmail.Attachments.Add sAnexo2


    ElseIf Range("v1").Value = 11 Then

    sAnexo1 = Range("a8").Value
    NovoEmail.Attachments.Add sAnexo1

    sAnexo2 = Range("a10").Value
    NovoEmail.Attachments.Add sAnexo2

    sAnexo3 = Range("a12").Value
    NovoEmail.Attachments.Add sAnexo3

    sAnexo4 = Range("a14").Value
    NovoEmail.Attachments.Add sAnexo4

    Else

    sAnexo1 = Range("a8").Value
    NovoEmail.Attachments.Add sAnexo1

    End If

    NovoEmail.Body = sCorpo

    NovoEmail.Display
    SendKeys sCorpo
    SendKeys "^v", False


    Sheets("Capa").Select

    End Sub

    Obrigado!!!

    domingo, 22 de março de 2020 13:09