如何在Excel VBA中修改自动发送邮件的发件人地址

以下是满足需求的修改后代码，关键修改点会在代码后说明：

Sub Send_Files()

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 sendAccount As Object ' 新增：存储指定发件邮箱账号

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set sh = Sheets("Sheet1")

Set OutApp = CreateObject("Outlook.Application")

' 新增：遍历Outlook账号，匹配目标共享邮箱
For Each sendAccount In OutApp.Session.Accounts
    ' 替换成实际的共享邮箱地址
    If sendAccount.SmtpAddress = "shared@yourcompany.com" Then
        Exit For
    End If
Next sendAccount

For Each cell In sh.Columns("A").Cells.SpecialCells(xlCellTypeConstants)

    'Enter the path/file names in the D:Z column in each row
    Set rng = sh.Cells(cell.Row, 1).Range("D1:Z1")
    
    If cell.Value Like "?*@?*.?*" And _
    Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)
        
        With OutMail
            .to = sh.Cells(cell.Row, 1).Value
            ' 移除：原抄送设置行已删除
            .Subject = "Example Subject 1"
            .Body = sh.Cells(cell.Row, 3).Value
            
            ' 新增：指定用共享邮箱发送
            If Not sendAccount Is Nothing Then
                .SendUsingAccount = sendAccount
            End If
            
            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 'Or use .Display/Send
        End With
        
        Set OutMail = Nothing
    End If
Next cell

Set OutApp = Nothing

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

关键修改说明： #

• 移除抄送功能：直接删除了原代码中.cc = sh.Cells(cell.Row, 2).Value这一行，彻底取消抄送设置。
• 指定共享邮箱发件：
  1. 新增sendAccount变量存储目标账号；
  2. 遍历Outlook已配置的账号，匹配你提供的共享邮箱SMTP地址（记得替换代码中的示例地址）；
  3. 创建邮件后，通过.SendUsingAccount = sendAccount指定发件邮箱。

注意：需要确保目标共享邮箱已经在你的Outlook中添加为账号，否则代码无法找到对应发件账户。

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