VBA 未通过正确的邮件地址发送邮件

Question

我有以下问题：我的宏应该通过另一个电子邮件地址发送邮件，但这不起作用。电子邮件地址已设置并存储在 Outlook 中。我也可以在帐户设置中查看它。我也尝试将此电子邮件设置为默认电子邮件，然后运行宏，但电子邮件仍然通过我的普通电子邮件地址发送。

我没有附上的部分只是邮件根据表格信息进行整理的部分。

有人可以向我解释一下如何确保这封邮件也是从第二个邮件地址发送的吗？

Sub Mails()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Table1") 
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
    Dim outlookApp As Object
    Dim mailItem As Object
    Set outlookApp = CreateObject("Outlook.Application")
    Dim i As Long
 
    Dim otherAccount As Object
    For Each acc In outlookApp.Session.Accounts
        If acc.DisplayName = [email protected] Then 
            Set otherAccount = acc
            Exit For
        End If
    Next acc
 
    If otherAccount Is Nothing Then
        Exit Sub
    End If
 
    For i = 1 To lastRow
        If IsDate(ws.Cells(i, "E").Value) Then
            Set mailItem = outlookApp.CreateItem(0)
            With mailItem
                .SendUsingAccount = otherAccount
                .To = ws.Cells(i, "F").Value
                ' .CC = ' optional
                .Subject = „Reminder" & ws.Cells(i, "A").Value
                .HTMLBody = "
.
.
.
.
                .Send
            End With
        End If
    Next i
 
    Set mailItem = Nothing
    Set outlookApp = Nothing
    Set otherAccount = Nothing
End Sub

Answer 1

我使用能够设置/提取其他帐户的功能。当然，必须在 Outlook 上配置相应的帐户。我的示例作为 Excel 的自动化工作。否则，

OLook

应该是 Outlook

Application

:

Function GetAccountOf(sEmailAddress As String, ByRef OLook As Object) As Object
  Dim oAccount As Object
  Set GetAccountOf = Nothing
  For Each oAccount In OLook.Session.Accounts
    If oAccount = sEmailAddress Then
      Set GetAccountOf = oAccount
      Exit Function
    End If
  Next oAccount
End Function

应该用下面的方式调用：

Sub SendUsingDifferentAccount()
 Dim OLook As New Outlook.Application
 Dim acc As Outlook.Account
 Dim Mitem As Outlook.MailItem
 
 Set Mitem = OLook.CreateItem(0)
    
   
    Set acc = GetAccountOf("[email protected]", OLook)
    If acc Is Nothing Then MsgBox "The respective account is not recognized...": Exit Sub
    If acc.DisplayName = "[email protected]" Then
        With Mitem
               
            .To = "..."
            .cc = "..."
            .BCC = "..."
         
            Set .SendUsingAccount = acc
         
            .Send
        End With
    End If
End Sub