通过指定帐户发送电子邮件

Question

当我向学生发送作业时，我会创建一个个性化的文件，我希望每个学生都可以处理这些文件。我使用 VBA 和 Excel 生成文件。

我将 Outlook 置于“脱机工作”模式，以便在将 Outlook 重新联机之前确保电子邮件具有正确的附件。然后我通常会点击“发送/接收所有文件夹”按钮，这样它们就会在我观看时立即消失。
这适用于我只使用我的工作电子邮件配置 Outlook 的工作。

在家里的 Outlook（Windows 10 机器上安装的应用程序）上，我配置了两个帐户。
帐户 #1 是来自个人域的个人电子邮件。
帐户 #2 是我的工作电子邮件帐户。

我想像在工作中一样生成电子邮件，并将它们放入我工作帐户的存储桶中。然后我会从那里发送它们。

但是，它们会进入我的个人帐户的支出桶中。我不希望学生收到来自无法识别的发件人的电子邮件。我也不希望他们回复那些电子邮件。

创建电子邮件的代码：

Sub makemail()
    Dim strLocation As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim OutAccount As Object
 
    Range("a1").Activate
    
    eaddy = ActiveCell.Offset(0, 4).Value 'student's e-mail address in a worksheet
    IndivFile = ActiveCell.Offset(0, 8).Value 'this is an identifier for the student's individual file
    LastName = ActiveCell.Offset(0, 1).Value ' student's last name
    
    Do Until ActiveCell.Value = ""
        Set OutApp = CreateObject("Outlook.Application")
        
        Set OutMail = OutApp.CreateItem(0)
        Set OutAccount = OutApp.Session.Accounts.Item(1)
        
        On Error Resume Next
        With OutMail
            .To = eaddy
            .CC = ""
            .BCC = ""
            .Subject = LastName & " (text that describes the assignment)"
            .Body = "(body of message)"
            strLocation = "(location of the individual attachments" & IndivFile & ".xlsx"
            .Attachments.Add (strLocation)
            .Send
        End With
        On Error GoTo 0
    
        Set OutMail = Nothing
        Set OutApp = Nothing
        Set OutAccount = Nothing
    
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
        
        ActiveCell.Offset(1, 0).Activate
        eaddy = ActiveCell.Offset(0, 4).Value
        IndivFile = ActiveCell.Offset(0, 8).Value
        LastName = ActiveCell.Offset(0, 1).Value
    Loop

End Sub

它将生成的电子邮件转储到帐户 #1：我的个人帐户的 outbucket 中。

我尝试将.Send 替换为.SendUsingAccount = OutApp.Session.Accounts.Item(2)

将任何内容放在括号中（包括 0 或 1）将意味着我在任何一个外桶中都看不到输出。 （不知道是否生成了电子邮件。它们可能位于我没有查看过的某个目录中。）

所以，我刚刚生成了所有电子邮件，它们出现在我个人帐户的存储桶中。
我选择了所有这些并将它们放入我的工作帐户的输出桶中。
我点击了“发送/接收”，他们哪儿也去不了。

如果我单独打开每封电子邮件并单击电子邮件中的“发送”按钮，它们就会发送。我在我发送的文件夹中看到它们。

我对 Outlook 了解不多。我想知道这是否是电子邮件中某种不匹配的证书问题？但如果是这样的话，为什么不批量发送，而是单独发送并打开电子邮件？

我刚刚测试过。如果电子邮件被标记为已读或未读，则没有区别。

我确实将我的工作电子邮件设置为 Outlook 中的主要帐户（文件 > 帐户设置 > 指定一个帐户作为主要帐户。

我的问题：

1. 有没有办法在代码方面将其放入第二个帐户的 outbucket（工作）？
   请记住，.SendUsingAccount = OutApp.Session.Accounts.Item(2) 不起作用。

2. 如果我不能这样做，有没有办法更改我的电子邮件帐户，使我的工作成为第一名？
   除了按特定顺序删除和重新安装吗？
   我确实进去了，并将工作电子邮件作为我的主要电子邮件。

3. 为什么他们不会在一个 outbucket 中发送（因为它们是从另一个 outbucket 拖放的），但如果您单独打开它们就会发送？

Answer 1

好的，找到了。其中一部分取决于转到“工具”>“参考”，然后确保选择了 Microsoft Outlook 16.0 对象库。当然，您可以在没有早期绑定的情况下执行此操作，但它似乎有所帮助。

这是我最终想出的代码：

Sub makemail()
Range("a1").Activate
    eaddy = ActiveCell.Offset(0, 4).Value
    IndivFile = ActiveCell.Offset(0, 8).Value
    LastName = ActiveCell.Offset(0, 1).Value

    Dim objOutlook As Object
    Dim objMail As Object

    Worksheets("Rollcall").Activate
    Set objOutlook = CreateObject("Outlook.Application")
    Dim oAccount As Outlook.Account
    Set oAccount = Outlook.Application.Session.Accounts(1)

    Debug.Print oAccount
    If oAccount = "outlook account you want to use" Then
        Debug.Print ("condition true")

           'Main Logic ============================================
           Do Until ActiveCell.Value = ""
               Set objMail = objOutlook.CreateItem(0)
               On Error Resume Next
               With objMail
                   .To = eaddy
                   '.CC = ""
                   '.BCC = ""
                   .Subject = (your subject)
                   .Body = "your outgoing message"
                   strLocation = "(location of attachment"
                   .Attachments.Add (strLocation)
                  Set .SendUsingAccount = oAccount
                   .Send
               End With

               Set objMail = Nothing

               ActiveCell.Offset(1, 0).Activate
               eaddy = ActiveCell.Offset(0, 4).Value
               IndivFile = ActiveCell.Offset(0, 8).Value
               LastName = ActiveCell.Offset(0, 1).Value
           Loop
        Set objOutlook = Nothing
    End If
End Sub

Answer 2

您似乎只需要在 Outlook 中设置/更改默认帐户。

更多信息请参见How To Set An Email Account As The Default Account In Outlook?。

此外，您可以使用 Outlook 项目的 SendUsingAccount 属性设置一个 Account 对象，该对象表示要在其下发送 MailItem 的帐户。 SendUsingAccount 属性可用于指定在调用Send 方法时应该用于发送MailItem 的帐户。

         Sub SendEmailFromAccount(ByVal application As Outlook.Application, _ 
            ByVal subject As String, ByVal body As String, ByVal recipients As String, ByVal smtpAddress As String) 

            ' Create a new MailItem and set the To, Subject and Body properties. 
            Dim newMail As Outlook.MailItem = DirectCast(application.CreateItem(Outlook.OlItemType.olMailItem), Outlook.MailItem) 
            newMail.To = recipients 
            newMail.Subject = subject 
            newMail.Body = body 

            ' Retrieve the account that has the specific SMTP address. 
            Dim account As Outlook.Account = GetAccountForEmailAddress(application, smtpAddress) 
            ' Use this account to send the email. 
            newMail.SendUsingAccount = account 
            newMail.Send() 
        End Sub 

        Function GetAccountForEmailAddress(ByVal application As Outlook.Application, ByVal smtpAddress As String) As Outlook.Account 

            ' Loop over the Accounts collection of the current Outlook session. 
            Dim accounts As Outlook.Accounts = application.Session.Accounts 
            Dim account As Outlook.Account 
            For Each account In accounts 
                ' When the email address matches, return the account. 
                If account.SmtpAddress = smtpAddress Then 
                    Return account 
                End If 
            Next             
        End Function