电子邮件自动化 VBA

Question

大家好

我正在研究电子邮件自动化，我需要为我团队的每个成员发送一封定制的电子邮件。为此，我使用 excel sheet，使用 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), "", "") & 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

问题终于解决了。在文档创建和对 filed 1 进行筛选之间没有足够的时间。所以，我需要将 .AutoFilter 声明放在循环之外，并将条件实例化添加到循环中

电子邮件自动化 VBA

Email Automation VBA

automation

vba

lotus