VBA技术问询：如何让发送的邮件保存至次要收件箱已发送文件夹

我有一段VBA脚本，能实现给用户发送工作表的功能，但需要让发送完成后的邮件保存到我的次要收件箱。我试过用MailItem对象的.Sender属性设置，但完全没效果。我已经拥有该次要收件箱的访问权限，求正确的解决方向。

当前使用的VBA代码如下：

Sub Send_email_fromtemplate(CardEmail, StaffName As String)
    Dim edress As String
    Dim subj, name As String
    Dim filename As String
    Dim outlookapp As Object
    Dim outlookmailitem As Object
    Dim myAttachments As Object
    Dim path As String
    Dim attachment As String
    Dim r As Long
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object
    Dim customername As String
    Dim EmailApp As Outlook.Application
    Dim app_Outlook As Object
    Set app_Outlook = CreateObject("Outlook.Application")
    Dim objEmail As MailItem
    Set objEmail = app_Outlook.CreateItem(olMailItem)
    Dim EmailItem As Outlook.MailItem
    Dim Destwb As Workbook

    Dim Sourcewb As Workbook
    Dim sEmailFrom As String
    r = 2

    Set Sourcewb = ActiveWorkbook
    sEmail_From = Sourcewb.Sheets("table1").Cells(1, 11)
    ActiveSheet.Copy

    Set Destwb = ActiveWorkbook

    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case ThisWorkbook.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "mmm-yy")
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    End With
    'Do While Sheet1.Cells(r, 1) <> ""
        Set outlookapp = CreateObject("Outlook.Application")
        'call your template
        Set outlookmailitem = outlookapp.CreateItemFromTemplate("C:\Users\user\CCStatement.oft")

        'Set myAttachments = Destwb.FullName
        'deifine your path for the attachment
        path = "C:\Users\user"
        edress = CardEmail
        name = ActiveSheet.Name
        subj = "Corporate Credit Card Statement for the period ended " & Sourcewb.Sheets("Table1").Cells(1, 6) & "- **To be completed & returned by " & Sourcewb.Sheets("Table1").Cells(1, 9) & " **"
        filename = Sheet1.Cells(r, 4)
        attachment = Destwb.FullName
        objEmail.SentOnBehalfOfName = sEmail_From
        outlookmailitem.Display
        With outlookmailitem

            '.To = edress
            .To = "useremail"
            .Sender = "senderemail" ' 这里设置无效，Sender是只读属性
            .CC = ""
            .BCC = ""
            .Subject = subj
            .Attachments.Add Destwb.FullName
            objEmail.SentOnBehalfOfName = sEmailFrom
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range
            With oRng.Find
                Do While .Execute(FindText:="xxxxx")
                    oRng.Text = name
                    Exit Do
                Loop
            End With
            Set xInspect = outlookmailitem.GetInspector

            .Display
            .Send

        End With
        With Destwb
            .Close
            Kill TempFilePath & TempFileName & FileExtStr
        End With

        'clear your email address
        edress = ""
        r = r + 1
    'Loop
    'clear your fields
    Set outlookapp = Nothing
    Set outlookmailitem = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
End Sub

解决方案 #

首先明确：MailItem.Sender是只读属性，无法通过代码直接设置，这就是你之前设置无效的原因。下面提供两种可行的解决方法：

方法1：指定发件账户，自动保存至对应已发送文件夹 #

通过SendUsingAccount属性指定用次要收件箱的账户发送邮件，发送后的邮件会自动保存在该账户的“已发送邮件”文件夹中。

修改代码步骤：
在创建outlookmailitem对象后，添加以下代码获取并指定账户：

' 遍历Outlook账户，找到次要收件箱对应的账户
Dim olAccount As Outlook.Account
For Each olAccount In app_Outlook.Session.Accounts
    ' 替换成你的次要收件箱邮箱地址
    If olAccount.SmtpAddress = "secondary@yourdomain.com" Then
        outlookmailitem.SendUsingAccount = olAccount
        Exit For
    End If
Next olAccount

方法2：直接指定已发送邮件的保存文件夹 #

如果不想改变发件账户，只想把已发送邮件存到次要收件箱的文件夹，可通过SaveSentMessageFolder属性指定目标文件夹。

修改代码步骤：
在邮件发送前，添加以下代码：

' 获取次要收件箱的"已发送邮件"文件夹
Dim sentFolder As Outlook.Folder
' 替换成次要收件箱的邮箱地址或显示名称
Set sentFolder = app_Outlook.Session.Folders("secondary@yourdomain.com").Folders("已发送邮件")
' 设置邮件保存路径
outlookmailitem.SaveSentMessageFolder = sentFolder

额外代码优化建议 #

1. 你代码中同时创建了objEmail和outlookmailitem两个邮件对象，逻辑冗余，建议删除objEmail相关的所有代码（因为你实际使用的是outlookmailitem）
2. 变量名不一致：定义了sEmailFrom但使用了sEmail_From，需要统一修正
3. 代码中重复调用了.Display，可以只保留一次

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