如何修改VBA宏使其从Outlook次要邮箱发送邮件？

要实现从次要邮箱发送邮件，核心是利用Outlook对象模型的SendUsingAccount属性指定发件账号。以下是修改后的完整代码：

Option Explicit
Public Sub Example()
   Dim olApp As Object
   Dim olMail As Object
   Dim olRecip As Object
   Dim olCCRecip As Object
   Dim olAtmt As Object
   Dim olAccount As Object ' 存储次要邮箱账号
   Dim iRow As Long
   Dim Recip As String
   Dim CCRecip As String
   Dim Subject As String
   Dim Body As String
   Dim Atmt As String
   Dim secondaryEmail As String

   iRow = 2
   secondaryEmail = "your-secondary-email@domain.com" ' 替换为你的次要邮箱地址

   Set olApp = CreateObject("Outlook.Application")

   ' 遍历账号集合，定位次要邮箱
   For Each olAccount In olApp.Session.Accounts
       If olAccount.SmtpAddress = secondaryEmail Then
           Exit For
       End If
   Next

   Dim Sht As Worksheet
   Set Sht = ThisWorkbook.Worksheets("Email List")

   Do Until IsEmpty(Sht.Cells(iRow, 1))

      Recip = Sht.Cells(iRow, 1).Value
      CCRecip = Sht.Cells(iRow, 2).Value
      Subject = Sht.Cells(iRow, 3).Value
      Body = Sht.Cells(iRow, 4).Value
      Atmt = Sht.Cells(iRow, 5).Value ' Attachment Path

      Set olMail = olApp.CreateItem(0)

      With olMail
         .SendUsingAccount = olAccount ' 指定从次要邮箱发送
         Set olRecip = .Recipients.Add(Recip)
         .Subject = Subject
         .Body = Body
         If Atmt <> "" Then ' 避免空附件路径报错
             Set olAtmt = .Attachments.Add(Atmt)
         End If
         olRecip.Resolve
         
         If CCRecip <> "" Then
             Set olCCRecip = .Recipients.Add(CCRecip)
             olCCRecip.Type = 2
             olCCRecip.Resolve
         End If
         .Display ' 如需自动发送，替换为.Send
      End With

      iRow = iRow + 1

   Loop

   Set olApp = Nothing
   Set olAccount = Nothing
End Sub

关键修改说明： #

• 新增olAccount变量存储次要邮箱账号实例，通过匹配SMTP地址遍历定位账号，比直接用索引（如Accounts.Item(2)）更可靠，避免账号顺序变化导致错误。
• 在邮件的With块中添加.SendUsingAccount = olAccount，明确指定发件邮箱。
• 新增空附件路径判断，避免单元格为空时添加附件触发报错。

使用前请将代码中的"your-secondary-email@domain.com"替换为你实际的次要邮箱地址。

内容的提问来源于stack exchange，提问作者user22737370