假设您有多个帐户附加到Outlook客户端，并希望能够选择使用VBA发送邮件的帐户。你是做什么？ MailItem.SendUsingAccount参数看起来是执行此操作的正确方法，建议在其他位置like here或here或here使用。但是，如果您在Developer Reference中应用该示例，则可能无法将SendUsingAccount属性设置为有效帐户。为什么？
这似乎就是答案：您必须将MailItem变暗为对象，将不变暗为Outlook.Mailitem。具有一个或多个Exchange帐户的Outlook客户端似乎无法可靠地将帐户分配给MailItem。但是，由于某些奇怪的原因，如果使用Dim As Object，则可以将Account附加到该Object。虽然该Object具有MailItem的属性，但它的行为 更好??? ......奇怪......
注意：代表其他人在上发送邮件符合略有不同的要求。
以下代码演示问题和解决方案。如果有其他解决方案或我遗失了什么，请告诉我。
运行代码并注意Msgbox信息后，在“立即窗口”中查找已完成操作的摘要。打印的摘要比具有大量Debug.Print语句的代码更清晰。有3个例程。主要测试例程和2从您的系统获取帐户详细信息。
（现已发布为separate question vacip的建议） 创建MailItem时，它们具有默认帐户的特征，例如可能需要更改的签名等。如果有人知道创建具有所选帐户特征的初始MailItem的好方法，请避免大量复制/粘贴/分配，请告诉我。
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
以下是在Outlook客户端上运行此程序的输出示例，该客户端附加了2个POP3和1个Exchange帐户：
''====================================================================================================
''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.)
答案 0 :(得分：0)
仅使用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
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