如何修改Outlook批量发件VBA代码以选择指定发件邮箱？

先修正原代码的语法问题（比如过程名称带空格），同时新增发件邮箱选择功能，以下是完整可用代码：

Option Explicit

Sub sendToMultiplePersons()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    Dim selectedAccount As Object ' 存储选中的发件邮箱账号
    Dim accountList As Variant
    Dim i As Integer
    Dim selectedIndex As Integer
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set sh = Sheets("Sheet1")
    Set OutApp = CreateObject("Outlook.Application")
    
    ' --- 新增：获取Outlook账号列表并让用户选择 ---
    ' 收集所有已配置的邮箱账号（显示名+邮箱地址）
    ReDim accountList(1 To OutApp.Session.Accounts.Count)
    For i = 1 To OutApp.Session.Accounts.Count
        accountList(i) = OutApp.Session.Accounts(i).DisplayName & " (" & OutApp.Session.Accounts(i).SmtpAddress & ")"
    Next i
    
    ' 弹出选择对话框
    selectedIndex = Application.InputBox( _
        Prompt:="请选择发件邮箱：" & vbCrLf & Join(accountList, vbCrLf), _
        Title:="选择发件邮箱", _
        Type:=1)
    
    ' 用户取消选择则终止操作
    If selectedIndex = 0 Then
        MsgBox "已取消操作", vbInformation
        GoTo Cleanup
    End If
    
    ' 绑定选中的邮箱账号
    Set selectedAccount = OutApp.Session.Accounts(selectedIndex)
    ' --- 新增结束 ---
    
    For Each cell In sh.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
        Set rng = sh.Cells(cell.Row, 1).Range("D1:M1")
        
        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
            
            With OutMail
                .SendUsingAccount = selectedAccount ' 指定发件邮箱
                .To = sh.Cells(cell.Row, 1).Value
                .CC = sh.Cells(cell.Row, 2).Value
                .Subject = sh.Cells(cell.Row, 5).Value
                .Body = sh.Cells(cell.Row, 3).Value
                
                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell.Value) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell
                
                '.Send ' 如需直接发送邮件，取消注释此行并注释下面的.Display
                .Display
            End With
            
            Set OutMail = Nothing
        End If
    Next cell
    
Cleanup:
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

关键修改说明 #

• 修正原代码中过程名称带空格的语法错误（VBA不允许过程名称包含空格）
• 新增账号列表收集逻辑：遍历Outlook中所有已配置的邮箱，生成带显示名和邮箱地址的选项列表，方便识别选择
• 新增账号选择交互：通过输入框让用户选择目标发件邮箱，取消选择则直接终止流程
• 新增.SendUsingAccount = selectedAccount：给每封邮件绑定选中的发件邮箱，替代默认发件账号

使用提示 #

• 若不需要预览邮件直接发送，注释掉.Display，取消.Send的注释即可
• 确保Outlook已正常登录并配置好多个邮箱账号，否则列表仅会显示默认账号

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