Question

我想使用Excel宏将邮件发送给公司。这封邮件应该由一段文字，一张表格和其余的文字组成。

在下面的函数中，我已经编译了一些可以按我想要的方式工作的代码，但是我希望不是通过个人帐户而是通过公司业务帐户发送电子邮件（在代码中，我指的是后者）作为myemailadres@outlook.com）。我认为我必须使用.SendUsingAccount函数，但是如果我按如下所示实现它，则电子邮件将使用我的个人电子邮件帐户发送，而不是我指定的电子邮件帐户。有人可以帮忙吗？

Sub Test()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim TargetSheet As String
Dim i As Long
Dim StrBodybegin As String
Dim StrBodyend As String
Dim Startcell
Dim TargetRow As Integer

   TargetSheet = Range("L24").value 'L24 refers to a name of a company, there is also a sheet in the workbook with the exact same name. 

    With Application.WorksheetFunction 'this I copied from the code from Ron de Bruijn
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        TargetRow = .Match("TOTAAL", ThisWorkbook.Worksheets(TargetSheet).Range("W1:W60"), 0) 'setting range of table I want to copy
        Set Startcell = ThisWorkbook.Worksheets(TargetSheet).Range("W15")
        Set rng = ThisWorkbook.Worksheets(TargetSheet).Range(Startcell, ThisWorkbook.Worksheets(TargetSheet).Cells(TargetRow + 1, 38))

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

        StrBodybegin = "Text 1"

        StrBodyend = "Text 2" 

        On Error Resume Next

        With OutMail
            .To = ThisWorkbook.Worksheets("Voorblad").Range("L23").value 'L23 refers to email adress
            .CC = ""
            .BCC = ""
            .Subject = "Subject" 
            .HTMLBody = StrBodybegin & RangetoHTML(rng) & StrBodyend 'using the Ron de Bruin function RangetoHTML to copy in the table defined by the rng
            .SendUsingAccount = OutApp.Session.Accounts("myemailadres@outlook.com") 'the line that does not work :(
            .Send
        End With

        On Error GoTo 0

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

        Set OutMail = Nothing
        Set OutApp = Nothing

    End With

End Sub

Answer 1

如果有权访问该邮箱或用户，则可以使用属性.SentOnBehalfOfName = "user@domain"。即使未添加到您的前景中，也是如此：

Option Explicit
Sub Test()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim TargetSheet As String
Dim i As Long
Dim StrBodybegin As String
Dim StrBodyend As String
Dim Startcell
Dim TargetRow As Integer

   TargetSheet = Range("L24").Value 'L24 refers to a name of a company, there is also a sheet in the workbook with the exact same name.

    With Application.WorksheetFunction 'this I copied from the code from Ron de Bruijn
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        TargetRow = .Match("TOTAAL", ThisWorkbook.Worksheets(TargetSheet).Range("W1:W60"), 0) 'setting range of table I want to copy
        Set Startcell = ThisWorkbook.Worksheets(TargetSheet).Range("W15")
        Set rng = ThisWorkbook.Worksheets(TargetSheet).Range(Startcell, ThisWorkbook.Worksheets(TargetSheet).Cells(TargetRow + 1, 38))

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

        StrBodybegin = "Text 1"

        StrBodyend = "Text 2"

        On Error Resume Next

        With OutMail
            .SentOnBehalfOfName = "user@domain"
            .To = ThisWorkbook.Worksheets("Voorblad").Range("L23").Value 'L23 refers to email adress
            .CC = ""
            .BCC = ""
            .Subject = "Subject"
            .HTMLBody = StrBodybegin & RangetoHTML(rng) & StrBodyend 'using the Ron de Bruin function RangetoHTML to copy in the table defined by the rng
            .SendUsingAccount = OutApp.Session.Accounts("myemailadres@outlook.com") 'the line that does not work :(
            .Send
        End With

        On Error GoTo 0

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

        Set OutMail = Nothing
        Set OutApp = Nothing
    End With

End Sub

Answer 2

通过accounts查找帐户循环。

Dim outApp As object, outNS as object
Dim accounts As object, account As object, myAccount As object

set outApp =createobject("outlook.application")
set outNS = outApp.GetNamespace("MAPI")
Set accounts = outNS.Accounts
For Each account in accounts
    if account.SmtpAddress = "myemailadrs@outlook.com" then
        set myAccount = account
        Exit For
    end if
Next account

With outApp.CreateItem(0)
    .to = "someone@abc.com"
    '...
    Set .SendUsingAccount = myAccount
    '....
End With

Answer 3

请尝试：

.SendUsingAccount  = outApp.GetNamespace("MAPI").accounts.Item("myemailadres@outlook.com")

并且，当您尝试调试时，建议对行On Error Resume Next进行注释。您看不到哪里和什么错误出现。实际上，如果一切正确，它根本不应该存在。.

使用其他电子邮件帐户发送邮件

3 个答案: