Question

我正在尝试通过Outlook（在Excel上启动）发送带有附件的电子邮件。该代码可以正常运行，但是在17封电子邮件中只有6封消失了，其余的卡在了发件箱中，当我打开Outlook并自己同步了文件夹时也消失了。

我尝试使用：DoEvents和Application.Wait（Now + TimeValue（“ 0:00:03”））无效。

For counter = 2 To 18

    branchCode = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("C" & counter).Value

    BranchName = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("A" & counter).Value
    branchEmail = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("D" & counter).Value
    sheetPath = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("J2").Value
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    On Error Resume Next

    With OutMail
        .To = branchEmail
        .BCC = ""
        .Subject = "Rate Sheet " & BranchName & " - " & Now()
        .Body = "Hi, Please find attached below your rate sheet, your uploads are ready as well."
        .Attachments.Add (sheetPath & BranchName & ".pdf")
        .Send
    End With
    On Error GoTo 0
    Application.Wait (Now + TimeValue("0:00:03"))
    Set OutMail = Nothing
    Set OutApp = Nothing

Next counter

Answer 1

请参阅代码调整。将循环初始化Outlook应用程序。您不应该一遍又一遍地打开和关闭这些文件，并且按照之前的评论，这实际上会引起一些问题，可能是先后打开和关闭客户端会导致同步问题。

选项1-将Outlook移动到外部循环

将初始化移到循环外部可能会解决您的问题。如果不是，请尝试选项2。

选项2-强制启动“所有帐户”同步组的同步

所有处理完成后，我们将使用以下方法获取同步组：

mySyncObjects = OutApp.GetNamespace("MAPI").SyncObjects

然后，我们将开始同步组1，通常是“所有帐户”。

mySyncObjects(1).Start

如果这不是“所有帐户”，则需要使用属性.Name

遍历mySyncObjects进行查找。

调整后的代码（请注意是否检查发送电子邮件）

'determine if you need to send emails
If needToSendEmails = 1 Then

Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")

For counter = 2 To 18



    branchCode = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("C" & counter).Value

    BranchName = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("A" & counter).Value
    branchEmail = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("D" & counter).Value
    sheetPath = Workbooks("Upload.xlsm").Worksheets("Branch List").Range("J2").Value

    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail
        .To = branchEmail
        .BCC = ""
        .Subject = "Rate Sheet " & BranchName & " - " & Now()
        .Body = "Hi, Please find attached below your rate sheet, your uploads are ready as well."
        .Attachments.Add (sheetPath & BranchName & ".pdf")
        .Send
    End With
    On Error GoTo 0
    ''This shouldn't be neccessary. I utilizie similar code to send 100+ emails quickly.  It takes a second for outlook to update but all should appear inside the app when processing complete.
    ''Application.Wait (Now + TimeValue("0:00:03")) 
    Set OutMail = Nothing


Next counter
''GET ALL SYNC GROUPS
Set mySyncObjects = OutApp.GetNamespace("MAPI").SyncObjects

''KICK OFF SYNC FOR ITEM 1 IN SYNC GROUPS, USUALLY ALL ACCOUNTS - MAY NEED TO LOOP THROUGH ALL SYNC GROUPS TO FIND "ALL ACCOUNTS"
mySyncObjects(1).Start

Set OutApp = Nothing

End If

使用VBA通过Outlook发送的电子邮件卡在发件箱中

1 个答案: