Envoyer un mail (via outlook) via une selection de donnée Excel

Version imprimable

Bonjour à tous,

Je fais une nouvelle fois appel a vous.

Je souhaite envoyer un mail a partir d'Excel sur une plage de donnée bien spécifique (A27:H27)
J'ai cherché sur pas mal de Forum et j'ai trouvé ce code

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
Sub PlageDeCellulesDansCorpsDuMessage()
'testé avec XP
'adapté de : http://support.microsoft.com/default.aspx?kbid=286430
Dim iMsg As Object, iConf As Object
Dim strHTML As String
Dim i As Byte, j As Byte
 
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
 
strHTML = ""
strHTML = strHTML & "<HEAD>"
strHTML = strHTML & "<BODY>"
strHTML = strHTML & "Bonjour , <BR>vous trouverez ci joint le tableau demandé<BR><BR>"
strHTML = strHTML & "<B><SPAN STYLE='background-color:green;font-size:6mm'>Résultats : </SPAN></B><BR><BR>"
strHTML = strHTML & "<TABLE BORDER>"
 
For a = 27 To 27 'nombre de lignes (exemple plage A1:B5)
    strHTML = strHTML & "<TR halign='middle'nowrap>"
    For h = 1 To 1 'nombre de colonnes
        strHTML = strHTML & "<TD bgcolor='yellow'align='center'><FONT COLOR='blue'SIZE=3>" _
        & Cells(a, h) & "</FONT></TD>"
    Next h
    strHTML = strHTML & "</TR>"
Next a
 
 
strHTML = strHTML & "</TABLE>"
 
strHTML = strHTML & "<BR><BR>Cordialement<BR>" & Environ("username")
strHTML = strHTML & "</BODY>"
strHTML = strHTML & ""
 
With iMsg
    Set .Configuration = iConf
    .To = " " 'renvoie une erreur si l'adresse est non valide
    '.From = "youralias@yourdomain.com"
    .Subject = "Test Envoi Tableau par mail"
    .HTMLBody = strHTML
 
End With
 
End Sub

Bien entendu je n'arrive pas à le modifier.
Je ne souhaite pas envoyer de PJ mais uniquement ma selection de plage de données dans le corps du texte.
et je n'ai pas d'adresse mail bénéficiaire de défini. Cela dépendra de chaque dossier.

Merci d'avance à tous !

Bonjour,test ça

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
87
88
89
90
91
92
Sub test()
Dim Html As String
Html = "<table border='1' cellspacing='0'>" & BodYHtml(Selection) & "</Table>"
Serveur = "smtp.googlemail.com"
Identify = True
User = "user"
PassWord = 1234
Port = 465
Delay = 10
Expediteur = "Moi@gmail.com"
Dest = "toi@gmai.com"
DestEnCopy = "lesautre@gmail.com"
Objet = "Suivi des modifications."
msg = "Voici le tableau sélectionné<br>"
Body = msg & Html
Pj = ""
 MailEnvoi Serveur, Identify, User, PassWord, Port, Delay, Expediteur, Dest, DestEnCopy, Objet, Body, Pj
End Sub
Function BodYHtml(R)
Dim C As Long
Dim L As Long
For L = 1 To R.Rows.Count
    BodYHtml = BodYHtml & "<TR>" & vbCrLf
        For C = 1 To R.Columns.Count
            BodYHtml = BodYHtml & "<TD >&nbsp" & R(L, C) & "</TD>" & vbCrLf
        Next
    BodYHtml = BodYHtml & "</TR>" & vbCrLf
Next
End Function
Public Sub MailEnvoi(Serveur, Identify, User, PassWord, Port, Delay, Expediteur, Dest, DestEnCopy, Objet, Body, Pj)
' sub pour envoyer les mails
Dim msg
Dim Conf
Dim Config
Dim ess
Dim splitPj
Dim IsplitPj
Set msg = CreateObject("CDO.Message") 'pour la configuration du message
Set Conf = CreateObject("CDO.Configuration") '  pour la configuration de l'envoi
Dim strHTML
 
Set Config = Conf.Fields
 
' Configuration des parametres d'envoi
'(SMTP - Identification - SSL - Password - Nom Utilisateur - Adresse messagerie)
With Config
If Identify = True Then
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = User
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = PassWord
End If
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Port
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Serveur
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = Delay
    .Update
 
End With
 
 
'Configuration du message
'If E_mail.Sign.Value = Checked Then Convert ServeurFrm.SignTXT, ServeurFrm.Text1
 
With msg
    Set .Configuration = Conf
    .To = Dest
  .cc = DestEnCopy
    .FROM = Expediteur
    .Subject = Objet
'
 
    .HTMLBody = Body '"<p align=""center""><font face=""Verdana"" size=""1"" color=""#9224FF""><b><br><font face=""Comic Sans MS"" size=""5"" color=""#FF0000""></b><i>" & body & "</i></font> " 'E_mail.ZThtml.Text
            If Pj <> "" Then
        splitPj = Split(Pj & ";", ";")
 
        For IsplitPj = 0 To UBound(splitPj)
            If Trim("" & splitPj(IsplitPj)) <> "" Then
                .AddAttachment Trim("" & splitPj(IsplitPj))
            End If
        Next
 
    End If
    .Send 'envoi du message
 
End With
' reinitialisation des variables
Set msg = Nothing
Set Conf = Nothing
Set Config = Nothing
 
End Sub

02/06/2014, 16h07
isa0144

Merci !
Je viens de tester et ca ne fonctionne pas.

Voici l'erreur

Code:

.Send 'envoi du message

et petite précision le mail sera envoyé via Outlook donc je pense que le parametrage Gmail n'est pas bon
non ???

ici on est pas dans Outlook j'ai repris la même idée que ton poste de départ!

tu as renseigné les informations?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Serveur = "smtp.googlemail.com"
Identify = True
User = "user"
PassWord = 1234
Port = 465
Delay = 10
Expediteur = "Moi@gmail.com"
Dest = "toi@gmai.com"
DestEnCopy = "lesautre@gmail.com"
Objet = "Suivi des modifications."
msg = "Voici le tableau sélectionné<br>"
Body = msg & Html
Pj = ""

02/06/2014, 16h17
isa0144

J'ai tenté mais vu qu'il s'agit d'une adresse mail du boulot je ne savais pas quoi mettre.
On sera plusieur a travailler sur ce fichier.

Il ne s'agit pas d'adresses mail GMAIL mais @nom de ma boite

Sais tu s'il existe un code avec outlook ?

Je débute totalement dans VBA et je dois avouer que c'est parfois du chinois ...

Citation:

Envoyé par isa0144

J'ai tenté mais vu qu'il s'agit d'une adresse mail du boulot je ne savais pas quoi mettre.
On sera plusieur a travailler sur ce fichier.

Il ne s'agit pas d'adresses mail GMAIL mais @nom de ma boite

je me doute bien .
les informations doivent être celles de ta boîte reporter les information de ton profile Outlook.
si non revoir l'envoi via Outlook.
Code:

1 2 3 4 5 6 7 8 9 10 Sub test() Set Outlook = CreateObject("Outlook.application") Set myItem = Outlook.CreateItem(olMailItem) myItem.To = EnvoyerA myItem.Subject = "je vous parle de ..." myItem.Body = "bla bla" myItem.Send Outlook.Quit End Sub

Commentaire du code

Bonjour,

J'ai vu votre code et je traite les mêmes problématiques. Je suis débutant et souhaiterait le comprendre pour initier un projet.

Pourriez-vous svp m'aider en commentant le code aux déclarations des fonctions, des procédures et des variables, afin que je puisse m'y retrouver ?

Je vous en serez reconnaissant..!!

D'avance Merci !!

Citation:

Envoyé par rdurupt

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
87
88
89
90
91
92
Sub test()
Dim Html As String
Html = "<table border='1' cellspacing='0'>" & BodYHtml(Selection) & "</Table>"
Serveur = "smtp.googlemail.com"
Identify = True
User = "user"
PassWord = 1234
Port = 465
Delay = 10
Expediteur = "Moi@gmail.com"
Dest = "toi@gmai.com"
DestEnCopy = "lesautre@gmail.com"
Objet = "Suivi des modifications."
msg = "Voici le tableau sélectionné<br>"
Body = msg & Html
Pj = ""
 MailEnvoi Serveur, Identify, User, PassWord, Port, Delay, Expediteur, Dest, DestEnCopy, Objet, Body, Pj
End Sub
Function BodYHtml(R)
Dim C As Long
Dim L As Long
For L = 1 To R.Rows.Count
    BodYHtml = BodYHtml & "<TR>" & vbCrLf
        For C = 1 To R.Columns.Count
            BodYHtml = BodYHtml & "<TD >&nbsp" & R(L, C) & "</TD>" & vbCrLf
        Next
    BodYHtml = BodYHtml & "</TR>" & vbCrLf
Next
End Function
Public Sub MailEnvoi(Serveur, Identify, User, PassWord, Port, Delay, Expediteur, Dest, DestEnCopy, Objet, Body, Pj)
' sub pour envoyer les mails
Dim msg
Dim Conf
Dim Config
Dim ess
Dim splitPj
Dim IsplitPj
Set msg = CreateObject("CDO.Message") 'pour la configuration du message
Set Conf = CreateObject("CDO.Configuration") '  pour la configuration de l'envoi
Dim strHTML
 
Set Config = Conf.Fields
 
' Configuration des parametres d'envoi
'(SMTP - Identification - SSL - Password - Nom Utilisateur - Adresse messagerie)
With Config
If Identify = True Then
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = User
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = PassWord
End If
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Port
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Serveur
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = Delay
    .Update
 
End With
 
 
'Configuration du message
'If E_mail.Sign.Value = Checked Then Convert ServeurFrm.SignTXT, ServeurFrm.Text1
 
With msg
    Set .Configuration = Conf
    .To = Dest
  .cc = DestEnCopy
    .FROM = Expediteur
    .Subject = Objet
'
 
    .HTMLBody = Body '"<p align=""center""><font face=""Verdana"" size=""1"" color=""#9224FF""><b><br><font face=""Comic Sans MS"" size=""5"" color=""#FF0000""></b><i>" & body & "</i></font> " 'E_mail.ZThtml.Text
            If Pj <> "" Then
        splitPj = Split(Pj & ";", ";")
 
        For IsplitPj = 0 To UBound(splitPj)
            If Trim("" & splitPj(IsplitPj)) <> "" Then
                .AddAttachment Trim("" & splitPj(IsplitPj))
            End If
        Next
 
    End If
    .Send 'envoi du message
 
End With
' reinitialisation des variables
Set msg = Nothing
Set Conf = Nothing
Set Config = Nothing
 
End Sub