通过指定的电子邮件地址发送电子邮件

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

Set .SendUsingAccount = otherAccount

不起作用。

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

已编辑：

请仅复制我发布的第一个

Sub

并尝试使用下一个改编代码：

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
    Set otherAccount = GetAccountOf("[email protected]", outlookApp)
    If otherAccount Is Nothing Then MsgBox "The respective account is not recognized...": Exit Sub
 
    For i = 1 To lastRow
        If IsDate(ws.Cells(i, "E").Value) Then
            Set mailItem = outlookApp.CreateItem(0)
            With mailItem
                Set .SendUsingAccount = otherAccount
                .To = ws.Cells(i, "F").Value
                ' .CC = ' optional
                .Subject = "Reminder" & ws.Cells(i, "A").Value
                .HTMLBody = "Test"

                .Send
            End With
        End If
    Next i
 
    Set mailItem = Nothing
    Set outlookApp = Nothing
    Set otherAccount = Nothing
End Sub

未经测试，但以这种方式适应它应该可以工作（我认为......）