Invio massivo conallegati

Ciao, prova ad aggiungere 1 secondo di attesa dopo aver spedito la mail precedente. Alla fine del ciclo For/Next, subito prima dell'indice i aggiungi:

DoEvents
Application.Wait Now + TimeValue("0:00:01") '<--1 secondo

Fatto, ma continua a darmi lo stesso errore quando eseguo l'istruzione .Send

Grazie comunque

Proviamo a fare un tentativo con queste modifiche. In pratica è stato aggiunto un controllo sull'istanza "Outlook". Se già c'è Outlook aperto allora lascia quell'istanza altrimenti ne crea una nuova. Poi è stato aggiunto un ciclo esterno che prova fino a 3 volte di spedite la mail processata. Se non riesce allora mostra il messaggio di errore. Tra un tentativo e l'altro c'è un'attesa di 2 secondi. C'è un'ulteriore attesa di 1 secondo tra una mail e quella successiva.

Option Explicit

Sub StampaUnioneConAllegati()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim FileAllegato As String
    Dim CartellaAllegati As String
    Dim Tentativi As Integer
    Dim MaxTentativi As Integer

    ' Imposta il foglio di lavoro e l'ultima riga dei dati
    Set ws = ThisWorkbook.Sheets("TestInvioComunicazione")
    
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Percorso della cartella contenente gli allegati
    CartellaAllegati = "C:\Documenti\Cooplat\Invio Massivo\FileRinominati\"

    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If OutApp Is Nothing Then
        Set OutApp = CreateObject("Outlook.Application")
    End If

    MaxTentativi = 3

    ' Loop attraverso ogni riga del foglio di lavoro
    For i = 2 To lastRow

        Dim EmailDestinatario As String
        Dim NomeFile As String

        EmailDestinatario = ws.Cells(i, 2).Value
        NomeFile = ws.Cells(i, 3).Value
        FileAllegato = CartellaAllegati & NomeFile

        Tentativi = 0
        Do While Tentativi < MaxTentativi
            On Error Resume Next
            ' Crea un nuovo messaggio di posta elettronica
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .To = EmailDestinatario
                .Subject = "Ricalcolo lavoro svolto nel periodo decorrente dal 07/2024 al 01/2025"
                .Body = "La preghiamo di prendere visione della comunicazione allegata." & vbCrLf & _
                        "Cordiali saluti." & vbCrLf & "COOPLAT."

                If Dir(FileAllegato) <> "" Then
                    .Attachments.Add FileAllegato
                Else
                    MsgBox "File non trovato: " & FileAllegato
                End If
                
                ' Visualizza o invia direttamente l'email
                '.Display() ' Per controllare l'email prima di inviarla
                .Send
            End With

            Set OutMail = Nothing
            DoEvents

            If Err.Number = 0 Then Exit Do

            Tentativi = Tentativi + 1
            Application.Wait Now + TimeValue("0:00:02")
            Err.Clear
        Loop

        If Tentativi = MaxTentativi Then
            MsgBox "Impossibile inviare email a: " & EmailDestinatario, vbCritical
        End If

        Application.Wait Now + TimeValue("0:00:01")

    Next i

    Set OutApp = Nothing

    MsgBox "Processo completato - " & (i - 2) & " mail inviate"
End Sub

Perfetto, ora funziona grazie mille 👍