EMAIL VBA et OUTlook

Version imprimable

Bonjour à tous,
J'ai réaliser avec excel un programme pour notre gestion du personnel de notre comite d'entreprise.
Pour communiquer avec les salariés de l'entreprise j'ai réaliser un programme qui me permet de récuperer mes adresse emails dans mon tableau excel
puis préparer l'envoi d'un email avec Outlook avec un CommandButton.
Lorsque je clique sur le bouton "ENVOI EMAIL" ma page outlook s'ouvre avec mes adresses emails en copie cachée. Je remplis mon email et je l'envoie.

Le problème est le suivant : Quand j'envoie mon email, il est pris en considération mais n'est pas envoyé. Il se retrouve dans la boite d'envoi sans être envoyer. Je suis donc obligé d'ouvrir Microsoft Outlook et c'est la que mon email va vraiment être envoyer.
Donc ma programmation est bonne mais je dois ouvrir outlook après. Comment éviter cettte manip de devoir ouvrir Outlook pour que mon email se trouve bien envoyé uniquement sur excel sans activer Microsoft outlook ?
Ci joint mon programme. Merci
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 Private Sub CommandButton8_Click() Sheets("listepersonnel").Select Dim xOutApp As Object Dim xOutMail As Object Dim xMailBody As String On Error Resume Next Set xOutApp = CreateObject("Outlook.Application") Set xOutMail = xOutApp.CreateItem(0) xMailBody = "" On Error Resume Next Dim I As Variant, ListeMail As String I = 2 ' ligne de la première adresse While Cells(I, 1) <> "" ' tant que l'addresse en colonne 4 et sur la ligne I n'est pas vide If Not Intersect(Cells(I, 3).SpecialCells(xlCellTypeVisible), Cells(I, 3)) Is Nothing Then ' si la cellule précitée est visible ListeMail = ListeMail & ";" & Cells(I, 3) ' je l'ajoute à la liste End If I = I + 1 ' je regarde la ligne suivante Wend 'EnvoyerMail (ListeMail) ' j'envoie la liste à la sub d'envoi With xOutMail .To = "" .CC = "" .BCC = ListeMail .Subject = "" .Body = xMailBody .Display 'or use .Send End With On Error GoTo 0 Set xOutMail = Nothing Set xOutApp = Nothing End Sub
J'ai un second problème : nous avons 2 PC et mon programme excel VBA fonctionne très bien. Mais le second pc que nous venons d'acheter fonctionne sous WINDOWS10 et Office 365. L'office ne dispose plus d'outlook. Et dans excel de ce nouveau office vba je n'ai plus dans "OUTILS" "REFERENCES" Microsoft Outlook Object library donc mon programme ne fonctionne plus sous cette nouvelle version office.
Merci de votre aide

18/12/2019, 20h59
Miraie

Bonjour,

Pour ton problème d'envoie, il se trouve a la ligne 27 de ton code. tu a ".display" d'actif et non ".send".

Cordialement,
27/12/2019, 11h06
arnaud.meu

Bonjour Miraie

Bonjour,
Je m'excuse je n'ai pas eu trop le temps de continuer mon projet.
J'ai essayé le .Send sa ne fonctionne pas.
.Display m'ouvre ma fenetre email je prépare mon email et j'envoie mais se retrouve "coincé" dans Outlook et je dois ouvrir l'application Micfrosoft Outlook pour être sur qu'il s'envoie.
.Send ma fenêtre email ne s'ouvre pas.

J'ai un second problème : nous avons 2 PC et mon programme excel VBA fonctionne très bien. Mais le second pc que nous venons d'acheter fonctionne sous WINDOWS10 et Office 365. L'office ne dispose plus d'outlook. Et dans excel de ce nouveau office vba je n'ai plus dans "OUTILS" "REFERENCES" Microsoft Outlook Object library donc mon programme ne fonctionne plus sous cette nouvelle version office.
Merci de votre aide
27/12/2019, 17h37
Miraie

Bonjour,
Pouvez vous nous envoyer votre code avec le .send actif?

En fait, votre code vous permet sois de visualliser et envoyer manuellement votre courriel ou de tout simplement l'envoyer. Pour l'envoyer tout simplement, utilisez le code suivant.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Private Sub CommandButton8_Click()
Sheets("listepersonnel").Select
Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    On Error Resume Next
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = ""
                  On Error Resume Next
  Dim I As Variant, ListeMail As String
I = 2 ' ligne de la première adresse
While Cells(I, 1) <> "" ' tant que l'addresse en colonne 4 et sur la ligne I n'est pas vide
If Not Intersect(Cells(I, 3).SpecialCells(xlCellTypeVisible), Cells(I, 3)) Is Nothing Then ' si la cellule précitée est visible
ListeMail = ListeMail & ";" & Cells(I, 3) ' je l'ajoute à la liste
End If
I = I + 1 ' je regarde la ligne suivante
Wend
'EnvoyerMail (ListeMail) ' j'envoie la liste à la sub d'envoi
 
    With xOutMail
        .To = ""
        .CC = ""
        .BCC = ListeMail
        .Subject = ""
        .Body = xMailBody
        .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub