使用不同的 Outlook 电子邮件地址从 Access 发送电子邮件答案

【问题标题】：Sending an email from Access using a different Outlook email address使用不同的 Outlook 电子邮件地址从 Access 发送电子邮件
【发布时间】：2016-05-22 08:57:35
【问题描述】：

我正在尝试使用与我的默认地址不同的 Outlook 地址从 Outlook 发送传真。下面是我的代码。

谢谢。

Private Sub FaxDoctor() ' 用信件传真医生出错时转到 Error_Handler 暗淡无光

Dim olApp As Object

' Dim olApp As Outlook.Application

Dim olNS As Outlook.NameSpace
Dim olfolder As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem
Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FileExists("\\pna434h0360\PharmServ\Output\" & Me!ID & ".pdf") Then ' If the filename is found
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set olfolder = olNS.GetDefaultFolder(olFolderInbox)
    Set olMailItem = olfolder.Items.Add("IPM.Note")
    olMailItem.display
    With olMailItem
        .Subject = " "
        .To = "[fax:" & "Dr. " & Me.[Prescriber First Name] & " " & Me.[Prescriber Last Name] & "@" & 1 & Me!Fax & "]" ' Must be formatted exactly to be sent as a fax
        '.Body = "This is the body text for the fax cover page" ' Inserts the body text
        .Attachments.Add "\\pna434h0360\PharmServ\Output\" & Me!ID & ".pdf" ' attaches the letter to the e-mail/fax
        '.SendUsingAccount = olNS.Accounts.Item(2) 'Try this to change email accounts
    End With

    Set olMailItem = Nothing
    Set olfolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
Else
    GoTo Error_Handler
End If

退出程序：出错时继续下一步退出子错误处理程序： MsgBox ("No Letter found" & vbCrLf & "如果您确定该字母以正确的文件名保存，则关闭 Outlook 并重试。") ' 这通常会崩溃，因为找不到该字母或 Outlook 已崩溃。在这种情况下，应关闭每个 Outlook 进程并重新启动 Outlook。退出子结束子

【问题讨论】：

标签： ms-access

【解决方案1】：

您可以使用邮件项目的“SendUsingAccount”属性更改 Outlook 帐户。这需要设置为帐户对象。

您可以使用类似这样的方式为给定名称设置帐户，其中“AccountName”是您发送邮件的地址。

Dim olAcc as Outlook.Account

For Each olAcc In Outlook.Session.Accounts
    If outAcc.UserName = 'AccountName' Then
        olMailItem.SendUsingAccount = outAcc
        Exit For
    End If
Next

【讨论】：

【解决方案2】：

尝试使用“.SendOnBehalfOfName”

我在网上找到了这个功能，所以跟着它走吧：

Function SendEmail()

Dim Application As Outlook.Application
Dim NameSpace As Outlook.NameSpace

Dim SafeItem, oItem ' Redemption

Set Application = CreateObject("Outlook.Application")

Set NameSpace = Application.GetNamespace("MAPI")

NameSpace.Logon


Set SafeItem = CreateObject("Redemption.SafeMailItem") 'Create an instance of Redemption.SafeMailItem
Set oItem = Application.CreateItem(0) 'Create a new message
SafeItem.Item = oItem 'set Item property
SafeItem.Recipients.Add "customer@ispprovider.com"
SafeItem.Recipients.ResolveAll
SafeItem.Subject = "Testing Redemption"
SafeItem.SendOnBehalfOfName = "Invoices@companyname.com"

SafeItem.Send

End Function

【讨论】：