Email Automation VBA

Question

Hy all

Я работаю над автоматизацией электронной почты, мне нужно отправить индивидуальный адрес электронной почты для каждого члена моей команды. Для этого я использую лист excel, кодирующий vba и использующий Lotus Notes для отправки электронной почты.

Я могу отправить только 1 письмо каждый раз, когда я обедаю программу, но мне нужно отправить 900 или более.

У меня есть следующая ошибка: '-2147417851 (80010105)': Ошибка автоматизации.

Вот код:

 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 

Благодаря

Answer 1

Наконец проблема решена. Недостаточно времени между созданием документа и фильтром на поданной 1. Итак, мне нужно отключить декларацию .AutoFilter из цикла и добавить критерий в петлю