Question

Hy大家

我正致力于电子邮件自动化，我需要为每个团队成员发送一封自定义的电子邮件。为此，我使用excel表，使用vba编码并使用Lotus Notes发送我的电子邮件。

每次午餐时，我只能发送一封电子邮件，但我需要发送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声明并将标准instanciation添加到循环中

电子邮件自动化VBA

1 个答案: