Problema com Loop ao enviar email

Bom dia a todos no forum...

Eu estou tendo um problema com o codigo abaixo para o qual preciso da vossa ajuda.

EU tenho um command button num formulario que deveria correr o seguinte:

1.) Criar um email por planta, juntando um relatorio especifico baseado no query "qryPlantsConcerned".
2.) Fazer um loop por cada planta até que todas as plantas tenham recebido o email
3.) Com o loop enviar este email a todos os contactos listados no query "qryEmailByBaucodeMP" em que o numero da plant é o mesmo que no query "qryPlantsConcerned"
4.) Correr tudo como “inner loop”


Funciona bem, mas após o primeiro email o codigo acaba por enviar o email para todos os contactos de uma só vez.

Eu já tentei de tudo e não estou conseguindo resolver o problema!

Em anexo junto a BD na expectativa de que me possam ajudar a resolver este problema...

Um abraço,

Paulo

Ola seja bem vindo ao forum;

Teste por favor;

Código:

Private Sub SendPCL_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim r2 As DAO.Recordset
Dim objMailItem As Object
Dim objMailOLApp As Object
Dim sthilf As String
   
    Const Vorlage = "K:\Logistik\Verzollung\AsiaBridge\VZIUziceNew.OFT"
   
Set db = CurrentDb
Set rs = db.OpenRecordset("Select Distinct Werk, TextDate FROM qryPlantsConcerned", dbOpenSnapshot)

If rs.RecordCount = 0 Then
    'se não tem registros, tem de fechar o recordset e limpar a memoria
        If Not (rs Is Nothing) Then
            rs.Close: Set rs = Nothing
            Set db = Nothing
            'morre aqui
            Exit Sub
        End If
End If

rs.MoveLast
rs.MoveFirst

Do Until rs.EOF
    On Error Resume Next
'cria uma instancia no outlook
    Set objMailOLApp = GetObject(, "Outlook.Application")
    Set objMailItem = objMailOLApp.CreateItemFromTemplate(Vorlage)
    Set r2 = db.OpenRecordset("SELECT DISTINCT CtCtEmail FROM qryEmailByBaucodeMP WHERE BAUCODE =" & rs("Werk"), dbOpenSnapshot)
       
If rs2.RecordCount = 0 Then
        'se não tem registros, tem de fechar o recordset e limpar a memoria
        If Not (rs2 Is Nothing) Then
            rs2.Close: Set rs2 = Nothing
            Set db = Nothing
            'morre aqui
            Exit Sub
        End If
End If

        r2.MoveLast
        r2.MoveFirst
       
        Do Until r2.EOF
            sthilf = sthilf & "; " & r2!CtctEmail
            Debug.Print sthilf
        r2.MoveNext
        Loop
    r2.Close
    Set r2 = Nothing
   
    With objMailItem
    .Subject = "Report Lisa NG " & rs!Werk
    .To = sthilf
    .Display          'Die E-Mail anzeigen (Anwender kann sie bearbeiten)
    .Attachments.Add "K:\PC&L Systems Improvement\Reporting\LISA NG\Database\DBreporting\" & rs!Werk & "\Report_LISA_NG_" & rs!Werk & "_" & rs!TextDate & ".pdf"
    End With
   
rs.MoveNext
Loop

rs.Close
Set rs = Nothing
Set db = Nothing
End Sub

Ola João Paulo...

Desde jà muito obrigado por sua resposta...

Eu testei o codigo que enviou mas infelizmente ainda não funciona...

O objectivo da loop é enviar um email separado por planta com todos os destinarios dessa mesma planta.

O problema é que o primeiro email para a primeira planta funciona perfeitamente, mas, a partir do segundo email o codigo está a incluir também os destinatarios do email anterior... e assim consecutivamente.

Será algum refresh faltando antes da loop?!?!

Não sei se fui esclarecedor o suficiente mas ficarei bastante agradecido se o João Paulo me puder ajudar a resolver este problema.

Obrigado,