[OL-2007] Changer l'expediteur du mail sur outlook

[Bernard67]

Bonjour le forum,

J'essaie sans succès de modifier cette macro afin d'envoyer une liste de mails avec des fichiers joints qui se trouvent sur un classeur excel en n'étant pas l'expediteur, mais comme expéditeur l'adresse de la BAL du service.(ex BALSERVICE@free.fr)

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
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
Sub envoi_mail()
 
    envoi = 0
    Sheets("Intro").Range("E8").Value = ""
 
     If Sheets("Liste_des_messages").Cells(8, 4) = "" Then
        MsgBox "Veuillez d'abord valider que les fiches sont bien à la bonne date, colonne E"
        Exit Sub
    End If
 
 
    ' k represente le nombre de message à envoyer
    For k = 0 To 1000
 
        ' si la cellule Cells(k + 2, 2) est vide, on arrete
        If Sheets("Liste_des_messages").Cells(k + 2, 2) = "" Then
            Exit For
        End If
 
    Next k
 
    ' on réinitialise l'affichage de l'avancement
    Sheets("Intro").Range("D12").Value = "Envoi du mail 0 / 0"
    Sheets("Intro").Range("D13").Value = "messages envoyés : 0"
 
 
    'pour toute les valeurs de k :
    For i = 2 To k + 1
 
     Sheets("Intro").Range("D12").Value = "Envoi du mail " & i - 1 & " / " & k
 
        Dim ol As Object, NOUVEAU_MESSAGE As Object
        Dim strBody As String
        'ol contient les fonctions d'outlook
        Set ol = CreateObject("outlook.application")
        Set NOUVEAU_MESSAGE = ol.CreateItem(olMailItem)
 
        courriel_to = Sheets("Liste_des_messages").Cells(i, 2)
        courriel_cc = Sheets("Liste_des_messages").Cells(i, 3)
        titre_mail = Sheets("Liste_des_messages").Cells(i, 4)
 
        corps_mail = Cells(i, 5) & Chr(10)
        corps_mail = corps_mail & "Bonjour," & Chr(10) & Chr(10)
        corps_mail = corps_mail & "Ci-joint les données ." & Chr(10) & Chr(10)
        corps_mail = corps_mail & "Cordialement," & Chr(10) & Chr(10) & Chr(10)
        corps_mail = corps_mail & "Contrôle " & Chr(10)
        corps_mail = corps_mail & "TOTO@orange.fr" & Chr(10) & Chr(10) & Chr(10)
 
        NOUVEAU_MESSAGE.To = courriel_to
        NOUVEAU_MESSAGE.cc = courriel_cc
        NOUVEAU_MESSAGE.Subject = titre_mail
        NOUVEAU_MESSAGE.Body = corps_mail
 
 
        j = 6
         For j = 6 To 20
 
            If Sheets("Liste_des_messages").Cells(i, j) = "" Then
                Exit For
            End If
 
            On Error Resume Next
             NOUVEAU_MESSAGE.Attachments.Add "\\Adresse des fichiers\" & Sheets("Liste_des_messages").Cells(i, j) & ".rtf"
            On Error GoTo 0
 
        Next j
 
              If j <> 6 Then
 
             envoi = envoi + 1
            Sheets("Intro").Range("D13").Value = "messages envoyés : " & envoi
 
             NOUVEAU_MESSAGE.Display
            Application.Wait (Now + TimeValue("00:00:02"))
 
            SendKeys "^{ENTER}", True
            Application.Wait (Now + TimeValue("00:00:04"))
 
             Set ol = Nothing
            Set NOUVEAU_MESSAGE = Nothing
        End If
 
    Next i
 
 
End Sub

Merci pour l'aide.
Cordialement

[danbenzi]

Bonjour Bernard,

J'ai un code que l'on m'a aidé à faire qui n'utilise pas OE. Peut être que cela peut te convenir en l'adaptant.

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
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
 
Option Explicit
 
Sub EnvoiMail()
Application.DisplayAlerts = False   'Supprime l'alerte Enregistrer
Dim objMessage As Variant
Dim nom As String
 
'ici on cré le chemin complet de ton fichier qui sera créé plus bas
nom = ActiveWorkbook.Path & "\lenomdufichier.xls"
 
'on crée le fichier et on le sauve avec le nom créé juste avant
'Copie la feuille dans le fichier à envoyer
ThisWorkbook.ActiveSheet.Copy       '
'Supprime les controls ou tout activx
Sheets(1).DrawingObjects.Delete
'Enregistre le fichier à envoyer avec le nom que l'on a cré plus haut
ActiveWorkbook.SaveAs nom
'Ferme le fichier
ActiveWorkbook.Close
 
On Error GoTo errorHandler
'on cré une instance de la reference "cdo" (message)
Set objMessage = CreateObject("CDO.Message")
 
'avec le message blablabla  blablabla
 With objMessage
.Subject = "Sujet du mail
.From = "BALSERVICE@free.fr"  'adresse mail de l'expéditeur n'est pas obligatoire
.To = Range("A1").Value 'Email du destinataire doit-être correct ici
.Cc = Range("A2").Value    'Email du destinataire en copie
 
'Crée le corps du message avec insertion de sauts de ligne
.TextBody =   "Bonjour," & Chr(10) & Chr(10)
& "Ci-joint les données ." & Chr(10) & Chr(10)
& "cordialement," & Chr(10) & Chr(10) & Chr(10)
& "Contrôle " & Chr(10)
& "TOTO@orange.fr" & Chr(10) & Chr(10) & Chr(10)
 
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.free.fr"  'remplacer ici le smtp par celui de son fournisseur d'accés
.Configuration.Fields.Update
.AddAttachment (nom)
.Send
MsgBox "Le mail a été bien envoyé !" 'Confirmation de l'envoi
        'après l'envoi le fichier créé est supprimé
Kill ActiveWorkbook.Path & "\" & "lenomdufichier.xls"
        'si erreur on sort de la procédure
Exit Sub
errorHandler:
        'description de l'erreur survenue
MsgBox Err.Description
End With
End Sub

A+
Dan