Email Automation VBA

Question

Hy everyone

I am working on email automation, I need to send a customized email for each member of my team. To do this I am using an excel sheet, coding with vba and using Lotus Notes to send my email.

I can send only 1 email each time I lunch the program but I need to send 900 or more.

I have an the following error '-2147417851 (80010105)': Automation Error .

Here is an the code :

     Sub Envoi_Email()
Dim range As range
Dim MailDoc As Object
Dim Notes As Object, db As Object, WorkSpace As Object
Dim UIdoc As Object, UserName As String, MailDbName As String
Dim Ligne As Long, CountRows As Long
Dim Var As Variant
Dim compteur_envoi As Long

compteur_envoi = 0
CountRows = Split(Worksheets("Courant").UsedRange.Address, "$")(4)



   Set Notes = CreateObject("Notes.NotesSession")
        UserName = Notes.UserName
        MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
        Set db = Notes.GetDataBase("", MailDbName)

        'wait function
        'Application.Wait (Now + TimeValue("0:00:10"))



For Ligne = 2 To CountRows

    If Left(Trim(Worksheets("Courant").Cells(Ligne, Column_Name("Industry*").Column)), 4) <> "BS01" And Left(Trim(Worksheets("Courant").Cells(Ligne, Column_Name("Industry*").Column)), 4) <> "BT01" And Left(Trim(Worksheets("Courant").Cells(Ligne, Column_Name("Industry*").Column)), 4) <> "BA03" And Left(Trim(Worksheets("Courant").Cells(Ligne, Column_Name("Industry*").Column)), 4) <> "BA04" And Left(Trim(Worksheets("Courant").Cells(Ligne, Column_Name("Industry*").Column)), 4) <> "BI01" And Left(Trim(Worksheets("Courant").Cells(Ligne, Column_Name("JOB*").Column)), 2) <> "LP" Then
  'Ouvrir la session


        Set WorkSpace = CreateObject("Notes.NotesUIWorkspace")
        Call WorkSpace.ComposeDocument(, , "Memo")
        Set UIdoc = WorkSpace.CURRENTDOCUMENT

        'wait function
        'Application.Wait (Now + TimeValue("0:00:10"))



        Var = Worksheets("Courant").Cells(Ligne, Column_Name("Mat*").Column)

        Call UIdoc.FieldSetText("EnterSendTo", Worksheets("Courant").Cells(Ligne, Column_Name("Email*").Column).Value) 'Recipient
        Call UIdoc.FieldSetText("Subject", "Congés au  " & Now)


      Worksheets("Courant").range("A1:" & Replace(Cells(1, Columns(Split(Worksheets("Courant").UsedRange.Address, "$")(3)).Column).Address(1, 5, 1), "$1", "") & CountRows).AutoFilter Field:=1, Criteria1:=Var, VisibleDropDown:=False
   'Worksheets("Courant").range("A1:AA22").AutoFilter Field:=1, Criteria1:=Var, VisibleDropDown:=False

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

                    Worksheets("Courant").range(Column_Name("CP2 *").Address & ":" & Left(Column_Name_Previous("SLD *").Address, Len(Column_Name_Previous("SLD *").Address) - 1) & CountRows).CopyPicture xlScreen, xlBitmap


        Call UIdoc.GotoField("Body")

        Call UIdoc.InsertText("Bonjour" & " " & Worksheets("Courant").Cells(Ligne, Column_Name("Nom*").Column) & vbNewLine)
        Call UIdoc.InsertText(Application.Substitute(vbNewLine & "@@Bien Cordialement,@Meriem", "@", vbCrLf))


        Call UIdoc.Paste

        Call UIdoc.Send(True)

        Call UIdoc.Close
        compteur_envoi = compteur_envoi + 1
        Set UIdoc = Nothing: Set WorkSpace = Nothing


    End If
   Set db = Nothing: Set Notes = Nothing

Next

Worksheets("Accueil").Cells(16, 3).Value = compteur_envoi
MsgBox "Envoi terminé"

End Sub

Thanks

Answer 1

Finally the problem is fixed. There was not enough time between the document creation and the filter on filed 1. So, I need to put out the .AutoFilter declaration out of the Loop and add the criteria instanciation into the loop