Comment choisir le compte Outlook à partir duquel un Mailitem est envoyé - en utilisant de manière fiable SendUsingAccount

disons que vous avez plusieurs comptes attachés à votre client Outlook et que vous voulez être en mesure de choisir lequel envoyer un courrier en utilisant VBA. Que faites-vous? Le MailItem.Le paramètre SendUsingAccount est la bonne façon de procéder et est recommandé ailleurs comme ici ou ici ou ici . Cependant, si vous appliquez l'exemple dans le référence du développeur , paramétrant le compte Sendusing la propriété à des comptes valides peut être impossible. Pourquoi?

il semble que ce soit la réponse : vous devez Dim votre MailItem comme un objet et pas comme une perspective.Mailitem. Il semble que les clients Outlook qui ont un ou plusieurs comptes Exchange n'assignent pas de comptes fiables à un MailItem. Mais, pour une raison étrange, si Dim As Object est utilisé à la place, le compte peut être attaché à cet objet. Bien que cet objet ait les propriétés D'un MailItem, il se comporte mieux??? ... étrange...

Note: L'envoi d'un courrier sur au nom de quelqu'un d'autre répond à une exigence légèrement différente.

le code suivant montre le problème et la solution en opération . S'il y a une autre solution ou je manque quelque chose s'il vous plaît laissez-moi savoir.

après avoir lancé le code et avoir noté les informations de la boîte aux lettres MSG, regardez dans la fenêtre immédiate pour un résumé de ce qui est fait. Le résumé imprimé est plus clair que le code qui a beaucoup de Debug.Imprimer les déclarations. Il y a 3 routines. La routine de test principale et 2 qui obtiennent les détails du compte de votre système.

(maintenant affiché comme une question séparée à vacip ' s suggestion) Quand les MailItems sont créés, ils ont les caractéristiques du compte par défaut,comme les signatures, etc. qui peut avoir besoin de changer. Si quelqu'un sait une bonne façon de créer le MailItem initial avec les caractéristiques d'un compte choisi à la place, en évitant beaucoup de copies/pâtes/assignations, s'il vous plaît laissez-moi savoir.

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

voici un échantillon de la sortie de l'exécution de ce programme sur un client Outlook qui a 2 POP3 et 1 compte de change attaché à elle:

    ''====================================================================================================
''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.)