如何选择从哪个Outlook帐户发送Mailitem - 可靠地使用SendUsingAccount [英] How to choose which Outlook Account a Mailitem is sent from - reliably using SendUsingAccount
本文介绍了如何选择从哪个Outlook帐户发送Mailitem - 可靠地使用SendUsingAccount的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
这似乎是答案：您必须将MailItem作为对象缩小，而将不作为Outlook。的MailItem。看来，具有一个或多个Exchange帐户的Outlook客户端无法将帐户可靠地分配给MailItem。但是，由于某些奇怪的原因，如果使用Dim As Object，则可以将该帐户附加到该对象。虽然该对象具有MailItem的属性，但它的行为更好？ ...奇怪...
注意：代表其他人发送邮件符合
以下代码演示了问题和解决方案。如果还有另外一个解决办法，或者我错过了什么，请让我知道。
运行代码并注意到Msgbox信息后，请查看即时窗口，了解完成的内容。打印的摘要比具有大量Debug.Print语句的代码更清晰。有3个例程。主要测试例程和2，从系统中获取帐户详细信息。
（现在发布为单独的问题在 vacip 的建议）
当创建MailItem时，它们具有默认帐户的特征，例如可能需要更改的签名等。如果有人知道创建具有所选帐户特征的初始MailItem的好方法，那么避免大量复制/粘贴/转让，请让我知道。
Private Sub TestSendingAccountProblems（）
'此测试演示了尝试设置
'时发生的问题， Outlook中MailItem的SendingAccount。
'总而言之，当Outlook客户端附有Exchange帐户时，
'似乎只能设置MailItem的SendingAccount如果
'邮件作为对象创建。
'一个裸的邮件失败并出现错误。
'MailItem的SendingAccount可以设置为Pop3或Exchange，只要MailItem是一个对象。
'当时Pop3或Exchange邮箱是否处于活动状态似乎并不重要。
'选择不同的邮箱会导致不同的签名被附加（如果已设置），但
'不会影响此SendingAccount行为。
'如果没有附加Exchange帐户，行为可能会有所不同 - 如果您有这样的系统，请尝试在
'Outlook客户端上。看看立即窗口中的列表
'让我们都知道你发现了什么。 （在立即窗口的VBIDE中的Cntrl-G）
'所有打印语句使得它和它调用的例程难以阅读。
'你可以开始运行它！
Dim appOl As Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim olMailItem As Outlook.MailItem
Dim objOutlookMsg As Object
Dim SendingAccount As Outlook .Account
Dim sOlPOP3Account As String
Dim sOlExchangeAccount As String
Dim arr（）As String
Dim i As Long
Dim NumAccts As Long
Dim S As String
Debug.Print String（100，=）
设置appOl = Outlook.Application
设置objNameSpace = appOl.GetNamespace（MAPI）
'请注意，这里的创建语句是相同的，这将创建一个Object来包含MailItem
Set objOutlookMsg = appOl.CreateItem（olItemType.olMailItem）'这将创建一个Object来包含MailItem
设置olMailItem = appOl.CreateItem（olItemType.olMailItem）'这创建一个简单的Mailitem。
'上面的行创建一个MailItem。
'唯一的区别是olMailItem被显式地维度为Outlook.MailItem。
'写出状态
S = objOutlookMsg.UserProperties.Session.CurrentUser.AddressEntry.Address
Debug.PrintobjOutlookMsg由具有此地址的用户创建：& ; S
S = olMailItem.UserProperties.Session.CurrentUser.AddressEntry.Address
Debug.PrintolMailItem由具有此地址的用户创建：& S
如果objOutlookMsg.SendUsingAccount是Nothing然后
Debug.PrintobjOutlookMsg.SendUsingAccount没有指定创建的帐户
Else
Debug.PrintobjOutlookMsg.SendUsingAccount.DisplayName = &安培; objOutlookMsg.SendUsingAccount.DisplayName
End If
如果olMailItem.SendUsingAccount不是，然后
Debug.PrintolMailItem.SendUsingAccount没有指定创建的帐户
Else
调试。打印olMailItem.SendUsingAccount.DisplayName =& olMailItem.SendUsingAccount.DisplayName
结束如果
'收集帐户DisplayNames
'这里的字符串必须是帐户名称。要查看这些，请执行以下操作：
'Outlook功能区：文件>帐户设置> AccountSettings-Name列。
'你可以在这里输入你自己的帐号，但是使用下面的代码，可以更容易地把它们全部提取出来。
'sOlPOP3Account =my.name@POP3server.com
'sOlExchangeAccount =my.name@ExchangeServer.com
'ReDim arr（1到2）
'NumAccts = 2
'arr（1）= sOlPOP3Account
'arr（2）= sOlExchangeAccount
'
'自动包含最多10个帐户
NumAccts = 0
对于i = 1到10
'选择所有帐户或只是其中一个：（不要同时暴露）
S = GetAccountNameOfType（vbNullString）'这将获得所有可从Outlook客户端'
'S = GetAccountNameOfType（POP3）'这将只获得可从Outlook客户端访问的Pop3帐户
如果S = vbNullString然后退出
NumAccts = NumAccts + 1
ReDim保存arr（1到NumAccts）
arr（NumAccts）= S
下一个i
对于i = 1到NumAccts
S = GetAccountType （arr（i），i）
On Error Resume Next
设置SendingAccount = appOl.Session.Accounts.Item（arr（i））
如果ERR<> 0或SendingAccount不是然后
Debug.Print String（20， - ）& vbLf&标准普尔帐户不能设置为变量SendingAccount。&标准普尔account has .DisplayName =& arr（i）
Else
Debug.Print String（20，+）& vbLf&标准普尔帐户WAS设置为变量SendingAccount。&标准普尔account has .DisplayName =& arr（i）
End If
'在使用附有Exchange帐户的Outlook客户端测试的所有场景中都能正常工作。
对象'观察窗口显示.SendingAccount =选择的帐户类型=帐户/帐户
错误恢复下一步
设置objOutlookMsg.SendUsingAccount = SendingAccount
如果ERR<> 0然后
Debug.PrintobjOutlookMsg.SendUsingAccount未设置，错误号为&错误& ，说明：& ERR.Description& - 查看上面列出的SendingAccount的状态（或者看看上面/查看Watch窗口中的步骤）。
Else
Debug.PrintobjOutlookMsg.SendUsingAccount已成功设置为： & objOutlookMsg.SendUsingAccount.DisplayName
End If
On Error Resume Next
'在所有使用连接了Exchange帐户的Outlook客户端进行测试的情况下，都会失败。
'观察窗口显示.SendingAccount =选择的类型=帐户/帐户
设置olMailItem.SendUsingAccount = SendingAccount
如果ERR<> 0然后
Debug.PrintolMailItem.SendUsingAccount未设置，错误号为&错误& ，说明：& ERR.Description& （SendingAccount可能是没有 - 看看上面/检查Watch窗口。）
Else
Debug.PrintolMailItem.SendUsingAccount成功设置为：& olMailItem.SendUsingAccount.DisplayName
End If
Next if
'清理
设置appOl = Nothing
设置objNameSpace = Nothing
设置olMailItem = Nothing
设置objOutlookMsg = Nothing
设置SendingAccount = Nothing
End Sub'启动与代码：
'https://social.msdn.microsoft.com / forum / en-US / 7a8bed41-a28f-41aa-bbc5-bfb8057a7bc4 / stuck-on-how-to-get-sendusingaccount to to work？forum = isvvba
'修改为创建返回当前的2个函数帐户的状态并一次显示所有帐户，整齐排列
'，另一个找到指定类型的帐户。
私有函数GetAccountType（sForDisplayName As String，_
可选lDisplayMessage As Long）As String
'返回名为sForDisplayName的帐户类型。
'仅当lDisplayMessage = +1或-1时才会显示所有帐户和类型的消息。
'注意：如果在Outlook _
中对电子邮件帐户进行了更改，则必须先关闭Outlook并重新打开，才能正常工作。
Dim objOutlook As Object
Dim objNameSpace As Object
Dim strAccountType As String
Dim strOlNameAccountType As String
Dim Account As Outlook.Account
Dim i As Long
Dim HitNum As Long
Dim bAcc As Boolean'确定是否返回给定类型的下一个帐户的帐户类型或帐户名称
Dim S As String'Scratch string
Dim S1 As String'Scratch string
Static LenStr As Long'MsgBox窗口中显示字符串的长度
静态lGT As Long'NumAccts中的帐号，我们已经达到
static sLstAcType As String'sGetNextAccountOfType中指定的最后一个帐户类型
静态NumAccts As Long'帐户数
设置objOutlook = CreateObject（Outlook.Application）
设置objNameSpace = objOutlook.GetNamespace（MAPI）
LenStr = 40
DO_AGAIN： '如果帐户名被发现为long，返回到这里
S = vbNullString
对于i = 1 To objNameSpace.Session.Accounts.Count
Set Account = objNameSpace.Session .Accounts.Item（i）
如果Len（Account.DisplayName）+ 10 + 1> LenStr Then
LenStr = Len（Account.DisplayName）+ 10 + 1
如果LenStr> 86然后LenStr = 86：转到GET_ON_WITH_IT
转到DO_AGAIN
结束如果
GET_ON_WITH_IT：
帐户
S1 =右（String（LenStr - 10， - ） & Account.DisplayName，LenStr - 10）
选择案例.AccountType
案例0
strAccountType =Exchange
strOlNameAccountType = Right（String（10， - ）& ;olExchange，10）'Watch Window显示olExchange
案例2
strAccountType =POP3
strOlNameAccountType = Right（String（10， - ）&olPop3，10 ）'Watch窗口显示olExchange
案例Else
strAccountType =不是POP3或Exchange帐户
strOlNameAccountType = Right（String（10， - ）&不是P3 / Exg 10）不知道什么观察窗口显示！
结束选择
S = S&我& - & Right（String（LenStr + 1， - ）& S1& vbTab& - & strOlNameAccountType，LenStr + 1）& vbLf
如果Abs（lDisplayMessage）= 1 Then _
Debug.Print Replace（i& - & Right（String（LenStr + 1， - ）& S1& vbTab& ; - & strOlNameAccountType，LenStr + 1）， - ，）
如果.DisplayName = sForDisplayName然后
GetAccountType = strAccountType
End If
End With
Next i
NumAccts = i - 1
'仅在lDisplayMessage = +1或-1时显示。如果未设置lDisplayMessage，则默认为不显示。
如果Abs（lDisplayMessage）= 1 Then _
MsgBox String（86， - ）& vbLf& 所有电子邮件帐户清单& Environ $（computername）& ：& vbLf& _
Left（ - Account& String（LenStr - Len（ - Account& vbTab&Type）， - ），LenStr） vbTab& 类型& vbLf& _
S& vbLf& _
String（86， - ）
设置objNameSpace = Nothing
设置objOutlook = Nothing
设置Account = Nothing
结束函数
私有函数GetAccountNameOfType（sTypeToGet As String）As String
'获取给定类型的下一个帐户。
'用相同的sTypeToGet重复调用返回最后找到的空字符串（或如果没有）。
'如果VBIDE被重置，它将从头开始重新开始。
'注意：如果在Outlook _
中对电子邮件帐户进行了更改，则必须先关闭Outlook并重新打开，才能正常工作。
Dim objOutlook As Object
Dim objNameSpace As Object
Dim strAccountType As String
Dim Account As Outlook.Account
Dim i As Long
Dim HitNum As Long
Dim bInit As Boolean'这是一个初始化运行
静态lGT As Long'NumAccts中的帐号我们已经达到
静态sLstAcType As String'最后一个帐户类型是在sTypeToGet
中指定静态NumAccts As Long'帐户数
如果NumAccts> 0然后
lGT = lGT + 1'获取下一个命中
Else
bInit = True'一定要先计算帐户
lGT = 1'，当
设置objOutlook = CreateObject（Outlook.Application）
设置objNameSpace = objOutlook.GetNamespace（MAPI）
对于i = 1 To objNameSpace.Session.Accounts.Count
设置帐户= objNameSpace.Session.Accounts.Item（i）
帐户
选择案例.AccountType
案例0
strAccountType =Exchange
案例2
strAccountType =POP3
案例Else
strAccountType =不是POP3或Exchange帐户
结束选择
如果UCase（strAccountType）= UCase（sTypeToGet）或sTypeToGet = vbNullString然后
HitNum = HitNum + 1
如果HitNum = lGT然后
GetAccountNameOfType = Account.DisplayName
如果不是bInit Then
如果sTypeToGet<> vbNullString Then NumAccts = HitNum
GoTo FOUNDIT
End If
End If
End If
End With
Next i
如果不是bInit Then
如果GetAccountNameOfType = vbNullString然后
NumAccts = 0
Else
NumAccts = i - 1
End If
Else
NumAccts = i - 1'初始化时始终保持计数
End If
FOUNDIT：
sLstAcType = sTypeToGet
设置objNameSpace = Nothing
设置objOutlook = Nothing
设置帐号=没有
结束功能
'https://social.msdn.microsoft.com/Forums/en-US/7a8bed41- a28f-41aa-bbc5-bfb8057a7bc4 / stick-on-how-to-get-sendusingaccount to to work？forum = isvvba
'被大量地修改为创建2个函数返回当前帐户的状态并显示所有帐户一次，整齐排列
'，另一个找到指定类型的帐户。
私有函数GetAccountType（sForDisplayName As String，_
可选lDisplayMessage As Long）As String
'返回名为sForDisplayName的帐户类型。
'仅当lDisplayMessage = +1或-1时才会显示所有帐户和类型的消息。
'注意：如果在Outlook _
中对电子邮件帐户进行了更改，则必须先关闭Outlook并重新打开，才能正常工作。
Dim objOutlook As Object
Dim objNameSpace As Object
Dim strAccountType As String
Dim strOlNameAccountType As String
Dim Account As Outlook.Account
Dim i As Long
Dim HitNum As Long
Dim bAcc As Boolean'确定是否返回给定类型的下一个帐户的帐户类型或帐户名称
Dim S As String'Scratch string
Dim S1 As String'Scratch string
Static LenStr As Long'MsgBox窗口中显示字符串的长度
静态lGT As Long'NumAccts中的帐号，我们已经达到
static sLstAcType As String'sGetNextAccountOfType中指定的最后一个帐户类型
静态NumAccts As Long'帐户数
设置objOutlook = CreateObject（Outlook.Application）
设置objNameSpace = objOutlook.GetNamespace（MAPI）
LenStr = 40
DO_AGAIN： '如果帐户名被发现为long，返回到这里
S = vbNullString
对于i = 1 To objNameSpace.Session.Accounts.Count
Set Account = objNameSpace.Session .Accounts.Item（i）
如果Len（Account.DisplayName）+ 10 + 1> LenStr Then
LenStr = Len（Account.DisplayName）+ 10 + 1
如果LenStr> 86然后LenStr = 86：转到GET_ON_WITH_IT
转到DO_AGAIN
结束如果
GET_ON_WITH_IT：
帐户
S1 =右（String（LenStr - 10， - ） & Account.DisplayName，LenStr - 10）
选择案例.AccountType
案例0
strAccountType =Exchange
strOlNameAccountType = Right（String（10， - ）& ;olExchange，10）'Watch Window显示olExchange
案例2
strAccountType =POP3
strOlNameAccountType = Right（String（10， - ）&olPop3，10 ）'Watch窗口显示olExchange
案例Else
strAccountType =不是POP3或Exchange帐户
strOlNameAccountType = Right（String（10， - ）&不是P3 / Exg 10）不知道什么观察窗口显示！
结束选择
S = S&我& - & Right（String（LenStr + 1， - ）& S1& vbTab& - & strOlNameAccountType，LenStr + 1）& vbLf
如果Abs（lDisplayMessage）= 1 Then _
Debug.Print Replace（i& - & Right（String（LenStr + 1， - ）& S1& vbTab& ; - & strOlNameAccountType，LenStr + 1）， - ，）
如果.DisplayName = sForDisplayName然后
GetAccountType = strAccountType
End If
End With
Next i
NumAccts = i - 1
'仅在lDisplayMessage = +1或-1时显示。如果未设置lDisplayMessage，则默认为不显示。
如果Abs（lDisplayMessage）= 1 Then _
MsgBox String（86， - ）& vbLf& 所有电子邮件帐户清单& Environ $（computername）& ：& vbLf& _
Left（ - Account& String（LenStr - Len（ - Account& vbTab&Type）， - ），LenStr） vbTab& 类型& vbLf& _
S& vbLf& _
String（86， - ）
设置objNameSpace = Nothing
设置objOutlook = Nothing
设置Account = Nothing
结束函数
私有函数GetAccountNameOfType（sTypeToGet As String）As String
'获取给定类型的下一个帐户。
'用相同的sTypeToGet重复调用返回最后找到的空字符串（或如果没有）。
'如果VBIDE被重置，它将从头开始重新开始。
'注意：如果在Outlook _
中对电子邮件帐户进行了更改，则必须先关闭Outlook并重新打开，才能正常工作。
Dim objOutlook As Object
Dim objNameSpace As Object
Dim strAccountType As String
Dim Account As Outlook.Account
Dim i As Long
Dim HitNum As Long
Dim bInit As Boolean'这是一个初始化运行
静态lGT As Long'NumAccts中的帐号我们已经达到
静态sLstAcType As String'最后一个帐户类型是在sTypeToGet
中指定静态NumAccts As Long'帐户数
如果NumAccts> 0然后
lGT = lGT + 1'获取下一个命中
Else
bInit = True'一定要先计算帐户
lGT = 1'，当
设置objOutlook = CreateObject（Outlook.Application）
设置objNameSpace = objOutlook.GetNamespace（MAPI）
对于i = 1 To objNameSpace.Session.Accounts.Count
设置帐户= objNameSpace.Session.Accounts.Item（i）
帐户
选择案例.AccountType
案例0
strAccountType =Exchange
案例2
strAccountType =POP3
案例Else
strAccountType =不是POP3或Exchange帐户
结束选择
如果UCase（strAccountType）= UCase（sTypeToGet）或sTypeToGet = vbNullString然后
HitNum = HitNum + 1
如果HitNum = lGT然后
GetAccountNameOfType = Account.DisplayName
如果不是bInit Then
如果sTypeToGet<> vbNullString Then NumAccts = HitNum
GoTo FOUNDIT
End If
End If
End If
End With
Next i
如果不是bInit Then
如果GetAccountNameOfType = vbNullString然后
NumAccts = 0
Else
NumAccts = i - 1
End If
Else
NumAccts = i - 1'初始化时始终保持计数
End If
FOUNDIT：
sLstAcType = sTypeToGet
设置objNameSpace = Nothing
设置objOutlook = Nothing
设置帐号=没有
结束功能
以下是在具有2个POP3和1个Exchange帐户的Outlook Client上运行此程序：
''===== ==================================================美元
' objOutlookMs g由具有此地址的用户创建：/ o = ExchangeLabs / ou = Exchange管理组（lotsofcharacter）/ cn =收件人/ cn = longhexnumberisplacedherefollowe-dname
''olMailItem由具有此地址的用户创建：/ o = ExchangeLabs / ou = Exchange管理组（lotsofcharacter）/ cn =收件人/ cn = longhexnumberisplacedherefollowe-dname
''objOutlookMsg.SendUsingAccount在创建时没有指定帐户
''olMailItem.SendUsingAccount没有指定帐户在创建
''olMailItem.SendUsingAccount没有指定创建的帐户
''1 joey.bloggs@POP3server.com olPop3
''2 jane.blogginnss@POP3server.com olPop3
''3 X@exchangeserver.com olExchange
''++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ POP3帐户具有.DisplayName = joey.bloggs@POP3server.com
''objOutlookMsg.SendUsingAccount成功设置为：joey.bloggs@POP3server.com
''olMailItem.SendUsingAccount未设置。错误编号为91，说明：对象变量或块变量未设置（SendingAccount可能为无 - 查看/查看监视窗口。）
''+++++++++ +++++++++++
''POP3帐户设置为变量SendingAccount。 POP3帐户具有.DisplayName = jane.blogginnss@POP3server.com
''objOutlookMsg.SendUsingAccount成功设置为：jane.blogginnss@POP3server.com
''olMailItem.SendUsingAccount未设置。错误编号为91，说明：对象变量或块变量未设置（SendingAccount可能为无 - 查看/查看监视窗口。）
''+++++++++ +++++++++++
''Exchange帐户设置为变量SendingAccount。 Exchange帐户具有.DisplayName = X@exchangeserver.com
''objOutlookMsg.SendUsingAccount成功设置为：X@exchangeserver.com
''olMailItem.SendUsingAccount未设置。错误编号为91，说明：对象变量或块变量未设置（SendingAccount可能是没有 - 查看/检查在监视窗口。）
解决方案
只有Exchange帐户，我转载了您的结果。问题可能在你的代码中。
我可以在mailitem上设置SendUsingAccount。
Sub sendFromEachAccount（）
Dim olAccounts As Accounts
Dim olMsg As mailItem
Dim i As Long
Dim accountCount As Long
accountCount = Session.Accounts.count
对于i = 1 to accountCount
设置olMsg = CreateItem（olMailItem）
Debug.Print帐户：&我& ：& DisplayName：& Session.Accounts（i）.DisplayName
使用olMsg
.SendUsingAccount = Session.Accounts.Item（i）
.Display
结束
Next i
ExitRoutine：
设置olMsg = Nothing
End Sub
Let's say you have several accounts attached to your Outlook client and want to be able to choose which one to send a mail from using VBA. What do you do? The MailItem.SendUsingAccount parameter looks the right way to do this and is recommended elsewhere like here or here or here. However, if you apply the example in the Developer Reference, setting the SendUsingAccount property to valid Accounts may be impossible. Why?
This appears to be the answer: You must Dim your MailItem as an Object and not as an Outlook.Mailitem. It appears that Outlook clients which have one or more Exchange Accounts do not reliably assign Accounts to a MailItem. But, for some strange reason, if Dim As Object is used instead, the Account can be attached to that Object. Though that Object has the Properties of a MailItem, it behaves better??? ... strange...
Note: Sending a mail on on behalf of someone else meets a slightly different requirement.
The following code demonstrates the problem and the solution in operation. If there is another solution or I am missing something please let me know.
After running the code and noting the Msgbox information, look in the Immediate Window for a summary of what is done. The printed summary is clearer than the code which has lots of Debug.Print statements. There are 3 routines. The main test routine and 2 which get Account details from your system.
(Now posted as a separate question at vacip's suggestion) When MailItems are created they have the characteristics of the default Account, such as signatures etc. which may need changing. If anyone knows a good way to create the initial MailItem with the characteristics of a chosen Account instead, avoiding a lot of copy/pastes/Assignments, please let me know.
Private Sub TestSendingAccountProblems()
'This test demonstrates the problems that occur when trying to set
' the SendingAccount of a MailItem in Outlook.
'In summary, it appears that when an Outlook client has an Exchange account attached,
' it is only possible to set the SendingAccount of a MailItem if
' THE MailItem IS CREATED AS AN OBJECT.
' A bare MailItem fails with an ERROR.
'The MailItem's SendingAccount can be set to Pop3 or Exchange, so long as the MailItem is an Object.
'It does not seem to matter whether a Pop3 or an Exchange Mailbox is active at the time.
' Choosing different mailboxes causes different signatures to be appended,(if set) but
' does not affect this SendingAccount behaviour.
'The behaviour probably is different if no Exchange account is attached - try it on your
' Outlook client if you have such a system. Look at the listings in the Immediate Window &
' let us all know what you discover. (Cntrl-G in the VBIDE for the Immediate Window)
'All the Print statements make this and the routines it calls rather hard to read.
'You can start by just running it!
Dim appOl As Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim olMailItem As Outlook.MailItem
Dim objOutlookMsg As Object
Dim SendingAccount As Outlook.Account
Dim sOlPOP3Account As String
Dim sOlExchangeAccount As String
Dim arr() As String
Dim i As Long
Dim NumAccts As Long
Dim S As String
Debug.Print String(100, "=")
Set appOl = Outlook.Application
Set objNameSpace = appOl.GetNamespace("MAPI")
'Notice that the Creation statements here are identical, this creates an Object to contain the MailItem
Set objOutlookMsg = appOl.CreateItem(olItemType.olMailItem) 'This creates an Object to contain the MailItem
Set olMailItem = appOl.CreateItem(olItemType.olMailItem) 'This creates a straightforward Mailitem.
'The line above creates a MailItem.
'The only difference is that olMailItem is explicitly Dimensioned as an Outlook.MailItem.
'Write out the status
S = objOutlookMsg.UserProperties.Session.CurrentUser.AddressEntry.Address
Debug.Print "objOutlookMsg was created by a user with this Address: " & S
S = olMailItem.UserProperties.Session.CurrentUser.AddressEntry.Address
Debug.Print "olMailItem was created by a user with this Address: " & S
If objOutlookMsg.SendUsingAccount Is Nothing Then
Debug.Print "objOutlookMsg.SendUsingAccount has no account specified on creation "
Else
Debug.Print "objOutlookMsg.SendUsingAccount.DisplayName = " & objOutlookMsg.SendUsingAccount.DisplayName
End If
If olMailItem.SendUsingAccount Is Nothing Then
Debug.Print "olMailItem.SendUsingAccount has no account specified on creation "
Else
Debug.Print "olMailItem.SendUsingAccount.DisplayName = " & olMailItem.SendUsingAccount.DisplayName
End If
'Collect the Account DisplayNames
'The strings here must be the Account Name. To see these, do this:
'Outlook Ribbon: File>Account Settings>AccountSettings-Name column.
' You can enter your own accounts here, but it is easier to let it fetch them all for you using the code below.
' sOlPOP3Account = "my.name@POP3server.com"
' sOlExchangeAccount = "my.name@ExchangeServer.com"
'ReDim arr(1 To 2)
' NumAccts = 2
' arr(1) = sOlPOP3Account
' arr(2) = sOlExchangeAccount
'
'Automatically includes up to 10 accounts
NumAccts = 0
For i = 1 To 10
' Choose all accounts or just one of these: (don't leave both exposed)
S = GetAccountNameOfType(vbNullString) 'This will get all accounts that are accessible from the Outlook client'
' S = GetAccountNameOfType("POP3") 'This will get only the Pop3 accounts that are accessible from the Outlook client
If S = vbNullString Then Exit For
NumAccts = NumAccts + 1
ReDim Preserve arr(1 To NumAccts)
arr(NumAccts) = S
Next i
For i = 1 To NumAccts
S = GetAccountType(arr(i), i)
On Error Resume Next
Set SendingAccount = appOl.Session.Accounts.Item(arr(i))
If ERR <> 0 Or SendingAccount Is Nothing Then
Debug.Print String(20, "-") & vbLf & S & " account could NOT be set to variable SendingAccount. The " & S & " account has .DisplayName = " & arr(i)
Else
Debug.Print String(20, "+") & vbLf & S & " account WAS set to variable SendingAccount. The " & S & " account has .DisplayName = " & arr(i)
End If
'Works fine in all scenarios tested using an Outlook client with an Exchange account attached.
Object ' The Watch Window shows .SendingAccount = chosen Account of Type = Account/Account
On Error Resume Next
Set objOutlookMsg.SendUsingAccount = SendingAccount
If ERR <> 0 Then
Debug.Print "objOutlookMsg.SendUsingAccount was NOT SET. The Error number is " & ERR & ", Description: " & ERR.Description & " - look at what was printed above for status of the SendingAccount (or look above/check in the Watch window if stepping through.)"
Else
Debug.Print "objOutlookMsg.SendUsingAccount was set successfully to: " & objOutlookMsg.SendUsingAccount.DisplayName
End If
On Error Resume Next
'Fails .in all scenarios tested using an Outlook client with an Exchange account attached.
' The Watch Window shows .SendingAccount = chosen Account of Type = Account/Account
Set olMailItem.SendUsingAccount = SendingAccount
If ERR <> 0 Then
Debug.Print " olMailItem.SendUsingAccount was NOT SET. The Error number is " & ERR & ", Description: " & ERR.Description & " (the SendingAccount may be 'Nothing' - look above/check in the Watch window.)"
Else
Debug.Print " olMailItem.SendUsingAccount was set successfully to: " & olMailItem.SendUsingAccount.DisplayName
End If
Next i
'Clean up
Set appOl = Nothing
Set objNameSpace = Nothing
Set olMailItem = Nothing
Set objOutlookMsg = Nothing
Set SendingAccount = Nothing
End Sub'Started with code from:
'https://social.msdn.microsoft.com/Forums/en-US/7a8bed41-a28f-41aa-bbc5-bfb8057a7bc4/stuck-on-how-to-get-sendusingaccount-to-work?forum=isvvba
'revised to create 2 functions that return the current account's status and displays all the accounts at one time, neatly lined up
'and another that finds accounts of a specified type.
Private Function GetAccountType(sForDisplayName As String, _
Optional lDisplayMessage As Long) As String
' Returns the type of the account named sForDisplayName.
' Shows a message listing all the accounts and types only if lDisplayMessage is = +1 or -1.
'NOTE: If changes to the email accounts have been made in Outlook _
then must close Outlook and Re-Open before any of this works properly.
Dim objOutlook As Object
Dim objNameSpace As Object
Dim strAccountType As String
Dim strOlNameAccountType As String
Dim Account As Outlook.Account
Dim i As Long
Dim HitNum As Long
Dim bAcc As Boolean 'Determines whether the Account Type or the Account name of the next Account of Given Type is returned
Dim S As String 'Scratch string
Dim S1 As String 'Scratch string
Static LenStr As Long 'The Length of the display string in the MsgBox window
Static lGT As Long 'Account number within NumAccts that we have reached
Static sLstAcType As String 'The last Account type that was specified in sGetNextAccountOfType
Static NumAccts As Long 'The number of Accounts
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
LenStr = 40
DO_AGAIN: 'Returns to here if the account names are found to be long
S = vbNullString
For i = 1 To objNameSpace.Session.Accounts.Count
Set Account = objNameSpace.Session.Accounts.Item(i)
If Len(Account.DisplayName) + 10 + 1 > LenStr Then
LenStr = Len(Account.DisplayName) + 10 + 1
If LenStr > 86 Then LenStr = 86: GoTo GET_ON_WITH_IT
GoTo DO_AGAIN
End If
GET_ON_WITH_IT:
With Account
S1 = Right(String(LenStr - 10, "-") & Account.DisplayName, LenStr - 10)
Select Case .AccountType
Case 0
strAccountType = "Exchange"
strOlNameAccountType = Right(String(10, "-") & "olExchange", 10) 'Watch Window shows olExchange
Case 2
strAccountType = "POP3"
strOlNameAccountType = Right(String(10, "-") & "olPop3", 10) 'Watch Window shows olExchange
Case Else
strAccountType = "Not POP3 or Exchange Account"
strOlNameAccountType = Right(String(10, "-") & "Not P3/Exg", 10) 'Don't know what Watch Window shows!
End Select
S = S & i & "-" & Right(String(LenStr + 1, "-") & S1 & vbTab & "-" & strOlNameAccountType, LenStr + 1) & vbLf
If Abs(lDisplayMessage) = 1 Then _
Debug.Print Replace(i & "-" & Right(String(LenStr + 1, "-") & S1 & vbTab & "-" & strOlNameAccountType, LenStr + 1), "-", " ")
If .DisplayName = sForDisplayName Then
GetAccountType = strAccountType
End If
End With
Next i
NumAccts = i - 1
'Only displays when lDisplayMessage = +1 or -1. Defaults to not displaying if lDisplayMessage is is unset.
If Abs(lDisplayMessage) = 1 Then _
MsgBox String(86, "-") & vbLf & "List of all Email Accounts on " & Environ$("computername") & ":" & vbLf & _
Left("- Account " & String(LenStr - Len("- Account " & vbTab & "Type"), "-"), LenStr) & vbTab & "Type" & vbLf & _
S & vbLf & _
String(86, "-")
Set objNameSpace = Nothing
Set objOutlook = Nothing
Set Account = Nothing
End Function
Private Function GetAccountNameOfType(sTypeToGet As String) As String
' Gets the next account of the given type.
' Called repeatedly with the same sTypeToGet returns a Null string on the last found (or if none are).
' If the VBIDE is reset, it starts again at the beginning.
'NOTE: If changes to the email accounts have been made in Outlook _
then must close Outlook and Re-Open before any of this works properly.
Dim objOutlook As Object
Dim objNameSpace As Object
Dim strAccountType As String
Dim Account As Outlook.Account
Dim i As Long
Dim HitNum As Long
Dim bInit As Boolean 'It is an initialisation run
Static lGT As Long 'Account number within NumAccts that we have reached
Static sLstAcType As String 'The last Account type that was specified in sTypeToGet
Static NumAccts As Long 'The number of Accounts
If NumAccts > 0 Then
lGT = lGT + 1 'Get the next hit
Else
bInit = True 'Be sure to count the accounts on the first run
lGT = 1 'and when the last exit resulted in no hit
End If
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
For i = 1 To objNameSpace.Session.Accounts.Count
Set Account = objNameSpace.Session.Accounts.Item(i)
With Account
Select Case .AccountType
Case 0
strAccountType = "Exchange"
Case 2
strAccountType = "POP3"
Case Else
strAccountType = "Not POP3 or Exchange Account"
End Select
If UCase(strAccountType) = UCase(sTypeToGet) Or sTypeToGet = vbNullString Then
HitNum = HitNum + 1
If HitNum = lGT Then
GetAccountNameOfType = Account.DisplayName
If Not bInit Then
If sTypeToGet <> vbNullString Then NumAccts = HitNum
GoTo FOUNDIT
End If
End If
End If
End With
Next i
If Not bInit Then
If GetAccountNameOfType = vbNullString Then
NumAccts = 0
Else
NumAccts = i - 1
End If
Else
NumAccts = i - 1 'Always keep a count when initialising
End If
FOUNDIT:
sLstAcType = sTypeToGet
Set objNameSpace = Nothing
Set objOutlook = Nothing
Set Account = Nothing
End Function
'https://social.msdn.microsoft.com/Forums/en-US/7a8bed41-a28f-41aa-bbc5-bfb8057a7bc4/stuck-on-how-to-get-sendusingaccount-to-work?forum=isvvba
'was heavily adapted to create 2 functions that return the current account's status and displays all the accounts at one time, neatly lined up
'and another that finds accounts of a specified type.
Private Function GetAccountType(sForDisplayName As String, _
Optional lDisplayMessage As Long) As String
' Returns the type of the account named sForDisplayName.
' Shows a message listing all the accounts and types only if lDisplayMessage is = +1 or -1.
'NOTE: If changes to the email accounts have been made in Outlook _
then must close Outlook and Re-Open before any of this works properly.
Dim objOutlook As Object
Dim objNameSpace As Object
Dim strAccountType As String
Dim strOlNameAccountType As String
Dim Account As Outlook.Account
Dim i As Long
Dim HitNum As Long
Dim bAcc As Boolean 'Determines whether the Account Type or the Account name of the next Account of Given Type is returned
Dim S As String 'Scratch string
Dim S1 As String 'Scratch string
Static LenStr As Long 'The Length of the display string in the MsgBox window
Static lGT As Long 'Account number within NumAccts that we have reached
Static sLstAcType As String 'The last Account type that was specified in sGetNextAccountOfType
Static NumAccts As Long 'The number of Accounts
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
LenStr = 40
DO_AGAIN: 'Returns to here if the account names are found to be long
S = vbNullString
For i = 1 To objNameSpace.Session.Accounts.Count
Set Account = objNameSpace.Session.Accounts.Item(i)
If Len(Account.DisplayName) + 10 + 1 > LenStr Then
LenStr = Len(Account.DisplayName) + 10 + 1
If LenStr > 86 Then LenStr = 86: GoTo GET_ON_WITH_IT
GoTo DO_AGAIN
End If
GET_ON_WITH_IT:
With Account
S1 = Right(String(LenStr - 10, "-") & Account.DisplayName, LenStr - 10)
Select Case .AccountType
Case 0
strAccountType = "Exchange"
strOlNameAccountType = Right(String(10, "-") & "olExchange", 10) 'Watch Window shows olExchange
Case 2
strAccountType = "POP3"
strOlNameAccountType = Right(String(10, "-") & "olPop3", 10) 'Watch Window shows olExchange
Case Else
strAccountType = "Not POP3 or Exchange Account"
strOlNameAccountType = Right(String(10, "-") & "Not P3/Exg", 10) 'Don't know what Watch Window shows!
End Select
S = S & i & "-" & Right(String(LenStr + 1, "-") & S1 & vbTab & "-" & strOlNameAccountType, LenStr + 1) & vbLf
If Abs(lDisplayMessage) = 1 Then _
Debug.Print Replace(i & "-" & Right(String(LenStr + 1, "-") & S1 & vbTab & "-" & strOlNameAccountType, LenStr + 1), "-", " ")
If .DisplayName = sForDisplayName Then
GetAccountType = strAccountType
End If
End With
Next i
NumAccts = i - 1
'Only displays when lDisplayMessage = +1 or -1. Defaults to not displaying if lDisplayMessage is is unset.
If Abs(lDisplayMessage) = 1 Then _
MsgBox String(86, "-") & vbLf & "List of all Email Accounts on " & Environ$("computername") & ":" & vbLf & _
Left("- Account " & String(LenStr - Len("- Account " & vbTab & "Type"), "-"), LenStr) & vbTab & "Type" & vbLf & _
S & vbLf & _
String(86, "-")
Set objNameSpace = Nothing
Set objOutlook = Nothing
Set Account = Nothing
End Function
Private Function GetAccountNameOfType(sTypeToGet As String) As String
' Gets the next account of the given type.
' Called repeatedly with the same sTypeToGet returns a Null string on the last found (or if none are).
' If the VBIDE is reset, it starts again at the beginning.
'NOTE: If changes to the email accounts have been made in Outlook _
then must close Outlook and Re-Open before any of this works properly.
Dim objOutlook As Object
Dim objNameSpace As Object
Dim strAccountType As String
Dim Account As Outlook.Account
Dim i As Long
Dim HitNum As Long
Dim bInit As Boolean 'It is an initialisation run
Static lGT As Long 'Account number within NumAccts that we have reached
Static sLstAcType As String 'The last Account type that was specified in sTypeToGet
Static NumAccts As Long 'The number of Accounts
If NumAccts > 0 Then
lGT = lGT + 1 'Get the next hit
Else
bInit = True 'Be sure to count the accounts on the first run
lGT = 1 'and when the last exit resulted in no hit
End If
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
For i = 1 To objNameSpace.Session.Accounts.Count
Set Account = objNameSpace.Session.Accounts.Item(i)
With Account
Select Case .AccountType
Case 0
strAccountType = "Exchange"
Case 2
strAccountType = "POP3"
Case Else
strAccountType = "Not POP3 or Exchange Account"
End Select
If UCase(strAccountType) = UCase(sTypeToGet) Or sTypeToGet = vbNullString Then
HitNum = HitNum + 1
If HitNum = lGT Then
GetAccountNameOfType = Account.DisplayName
If Not bInit Then
If sTypeToGet <> vbNullString Then NumAccts = HitNum
GoTo FOUNDIT
End If
End If
End If
End With
Next i
If Not bInit Then
If GetAccountNameOfType = vbNullString Then
NumAccts = 0
Else
NumAccts = i - 1
End If
Else
NumAccts = i - 1 'Always keep a count when initialising
End If
FOUNDIT:
sLstAcType = sTypeToGet
Set objNameSpace = Nothing
Set objOutlook = Nothing
Set Account = Nothing
End Function
Here is a sample of the output from running this program on an Outlook Client that has 2 POP3 and 1 Exchange account attached to it:
''====================================================================================================
''objOutlookMsg was created by a user with this Address: /o=ExchangeLabs/ou=Exchange Administrative Group (lotsofcharacter)/cn=Recipients/cn=longhexnumberisplacedherefollowe-dname
''olMailItem was created by a user with this Address: /o=ExchangeLabs/ou=Exchange Administrative Group (lotsofcharacter)/cn=Recipients/cn=longhexnumberisplacedherefollowe-dname
''objOutlookMsg.SendUsingAccount has no account specified on creation
''olMailItem.SendUsingAccount has no account specified on creation
''olMailItem.SendUsingAccount has no account specified on creation
''1 joey.bloggs@POP3server.com olPop3
''2 jane.blogginnss@POP3server.com olPop3
''3 X@exchangeserver.com olExchange
''++++++++++++++++++++
''POP3 account WAS set to variable SendingAccount. The POP3 account has .DisplayName = joey.bloggs@POP3server.com
''objOutlookMsg.SendUsingAccount was set successfully to: joey.bloggs@POP3server.com
'' olMailItem.SendUsingAccount was NOT SET. The Error number is 91, Description: Object variable or With block variable not set (the SendingAccount may be 'Nothing' - look above/check in the Watch window.)
''++++++++++++++++++++
''POP3 account WAS set to variable SendingAccount. The POP3 account has .DisplayName = jane.blogginnss@POP3server.com
''objOutlookMsg.SendUsingAccount was set successfully to: jane.blogginnss@POP3server.com
'' olMailItem.SendUsingAccount was NOT SET. The Error number is 91, Description: Object variable or With block variable not set (the SendingAccount may be 'Nothing' - look above/check in the Watch window.)
''++++++++++++++++++++
''Exchange account WAS set to variable SendingAccount. The Exchange account has .DisplayName = X@exchangeserver.com
''objOutlookMsg.SendUsingAccount was set successfully to: X@exchangeserver.com
'' olMailItem.SendUsingAccount was NOT SET. The Error number is 91, Description: Object variable or With block variable not set (the SendingAccount may be 'Nothing' - look above/check in the Watch window.)
解决方案
With Exchange accounts only, I reproduced your results. The problem could be in your code.
I can set SendUsingAccount on mailitem.
Sub sendFromEachAccount()
Dim olAccounts As Accounts
Dim olMsg As mailItem
Dim i As Long
Dim accountCount As Long
accountCount = Session.Accounts.count
For i = 1 To accountCount
Set olMsg = CreateItem(olMailItem)
Debug.Print "Account: " & i & ": " & "DisplayName: " & Session.Accounts(i).DisplayName
With olMsg
.SendUsingAccount = Session.Accounts.Item(i)
.Display
End With
Next i
ExitRoutine:
Set olMsg = Nothing
End Sub
这篇关于如何选择从哪个Outlook帐户发送Mailitem - 可靠地使用SendUsingAccount的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
