Microsoft 365 Changer le compte par defaut VBA

[sasuketm]

Bonjour à tous,

Je planche sur un fichier qui me permette d'envoyer des mails automatiquement depuis excel.

Jusqu'ici tout fonctionne mais il y a un point qui me pose problème.

Possédant 2 adresses mails dans outlook j'arrive via le code à changer l'adresse mail de l'expéditeur mais lorsque j'envoie les mails j'ai un retour en erreur car le compte outlook par défaut prend le dessus :

Voici le code qui me permet de changer l'adresse de l'expéditeur :

Sub mailto_reception2()
With Sheets("Envoi confirmation recep UPS")
    dl = .Cells(Rows.Count, 2).End(xlUp).Row
   
    Set ol = CreateObject("outlook.application")
        '--boucle
    For i = 2 To dl
        '--choix envoi ("x" en colonne G) ou pas
        If Cells(i, 11) = "x" Then
        Cells(i, 12) = ""
        Set ml = ol.createitem(0)
        ml.To = .Cells(i, 6)
        ml.Subject = .Cells(i, 17)
        'ml.CC = .Cells(i, 10)
        'ml.BCC = .Cells(i, 11)
        ml.Body = .Cells(i, 18)
        '--afficher le mail
        'ml.SentOnBehalfOfName = "test@test.eu" change bien le mail d'expéditeur mais prend le compte par défault d'outlook
        ml.Display

        '--- si vous souhaitez envoyer directement
        'ml.send
        '--- afficher date et heure d'envoi
        Cells(i, 12) = Now
       '---demande AR
        'ml.OriginatorDeliveryReportRequested = True
        '---demande confirmation de lecture
        'ml.ReadReceiptRequested = True
        End If
    Next i
End With
End Sub

J'ai mis en commentaire la ligne qui me pose problème, il y a t'il une solution pour basculer le compte outlook ?.

Merci pour vos retour

 

[danielco]

Bonjour,

Essaie :

Sub mailto_reception2()
Dim C As Account
With Sheets("Envoi confirmation recep UPS")
    dl = .Cells(Rows.Count, 2).End(xlUp).Row
    
    Set ol = CreateObject("outlook.application")
        '--boucle
    For i = 2 To dl
        '--choix envoi ("x" en colonne G) ou pas
        If Cells(i, 11) = "x" Then
        Cells(i, 12) = ""
        Set ml = ol.createitem(0)
        ml.To = .Cells(i, 6)
        ml.Subject = .Cells(i, 17)
        'ml.CC = .Cells(i, 10)
        'ml.BCC = .Cells(i, 11)
        ml.Body = .Cells(i, 18)
        '--afficher le mail
    With ml
        .Recipients.Add "test@test.com"
        For Each C In olApp.Session.Accounts
          If C.SmtpAddress = "enlevement-sav@kingtony.eu" Then
              .SendUsingAccount = C
              Exit For
          End If
        Next C
        .Display
        .Send
    End With
        ml.Display

        '--- si vous souhaitez envoyer directement
        'ml.send
        '--- afficher date et heure d'envoi
        Cells(i, 12) = Now
       '---demande AR
        'ml.OriginatorDeliveryReportRequested = True
        '---demande confirmation de lecture
        'ml.ReadReceiptRequested = True
        End If
    Next i
End With
End Sub

Il faut cocher la référence Microsoft Outlook 16.0 Object Library.

Cordialement.

Daniel

 

[sasuketm]

Bonjour et merci pour ton retour.

Cependant l'lorsque je rentre ta modification j'ai un message d'erreur sur la ligne 23 :

J'avoue que la je ne comprends vraiment pas où est le problème est-ce que cela parle a quelqu'un ?

Merci d'avance !

 

[danielco]

Bonjour,

Mets :

For Each C In ol.Session.Accounts

à la place (au temps pour moi).

Daniel

 

[sasuketm]

Suuuupeerrrr ça fonctionne merci danielco

Je vais paraitre un peu dans l'abus mais j'aurais un dernier point à voir si ça te dérange pas.

Dans le code suivant :

Sub Supprmail()
    Dim n%, i%  'Déclaration des variables
    Application.ScreenUpdating = False
    With Worksheets("mafeuil1") 'Nom de la feuille à modifier suivant le cas
        n = .Range("A" & .Rows.Count).End(xlUp).Row 'N° de la dernière ligne remplit
          For i = n To 2 Step -1 'Boucle de la dernière ligne remplit vers la ligne 2 (première ligne remplit) par PAS de -1
              If Range("A" & i) > 0 Then .Range("A" & i & ":E" & i).EntireRow.Delete 'si la ligne de la colonne A est = à 0 , suppression de la ligne
          Next i
    End With
End Sub

Je demande de supprimer des cellules sur "mafeuil1". Cela fonctionne mais seulement quand la feuille est active et pas quand je suis sur la feuille2 (là où est le bouton).

J'ai réussi à adapter ce code par rapport a mes besoins en faisant une vérification de la dernière cellule de la colonne A mais l'idéal serait que je puisse supprimer une zone entière plutôt. Du genre suppression de A2 à E500 par exemple.

Est-ce que tu serais m'aider pour ses 2 points ?

Merci encore pour ton aide !

 

[danielco]

Il manque un point devant "range" (If .Range(...) :

If .Range("A" & i) > 0 Then .Range("A" & i & ":E" & i).EntireRow.Delete

Daniel

 

[sasuketm]

Merci beaucoup pour ton aide et ton temps danielco.

Tout fonctionne c'est impeccable.

Merci

 

[sasuketm]

Bonjour danielco,

Mauvaise nouvelle mais en fait le code ne change pas l'expéditeur du mail comme il devrait. C'est toujours le compte par defaut qui est utilisé en fait. Je pensais que c'était bon mais cela ne marche pas.

Aurais tu une idée ?

 

[danielco]

Bonjour,

Est-ce que le compte "test@test.eu" existe vraiment ? Il doit faire partie des comptes enregistrés dans Outlook.

Daniel

 

[sasuketm]

Oui il existe bien dans les comptes Outlook.

 

[danielco]

Désolé. Au lieu de :

.SendUsingAccount = C

mets :

Set .SendUsingAccount = C

(je ne le ferais plus !)

Daniel