Discussion :

[evx136]

Bonjour,

Je souhaiterai trouver un code qui me permette d'envoyer par mail à plusieurs destinataires un fichier excel qui le concerne.

les fichiers excel sont stockés dans un dossier.
ma base de données d'adresses mails et dans un autre fichier excel dans un feuille.

Je souhaite également que le code puisse eviter tous les messages et meme je crois protection lors de l'envoie du mail automatiquement.

j'utilise Outlook

Merci de m'aider

Cordialement

[YANN-56]

Bonjour, et à ceux qui passeront par là.

Au bénéfice de ce que j'ai pu apprendre ici, voici le principe que j'utilise:
(Sans cette cochonnerie d'OutLook)

Il y a certainement lieu d'y apporter nombre d'améliorations et corrections!
A noter qu'ici, les adresses sont dans la Feuille "ADRESSES" du Classeur,
pour simplifier.

1 USF avec 2 TexBoxes, 2 Boutons, 1 WebBrowser et 1 Label

En premier lieu: Activer "Microsoft CDO for windows 2000 library"
dans les Références VBA

Créer:

Module 1 avec:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Public MAIL_ENVOYE As Boolean
Public DESTINATAIRE As String
Public SUJET As String

Module 2 avec:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Public Function ENVOI_PAR_MAIL() As Boolean
 
On Error GoTo ENVOI_PAR_MAIL_Err
Dim AROBASE As Variant
Dim SLASH As Variant
SLASH = "\"
 
AROBASE = "@" 'Pour récupérer sur la droite du TextBox1; le nom de votre serveur.
 
Dim ADRESSE As String
 
ADRESSE = "Smtp." & Right(UserForm1.TextBox1.Text, _
                 (Len(UserForm1.TextBox1.Text) _
                - InStrRev(UserForm1.TextBox1.Text, AROBASE, -1)))
 
Dim NOUVEAU_MESSAGE As New CDO.MESSAGE
 
NOUVEAU_MESSAGE.MDNRequested = True ' Demande d'Accusé de Réception
 
NOUVEAU_MESSAGE.From = UserForm1.TextBox1.Text ' Pour le test: Venant de Vous
NOUVEAU_MESSAGE.To = DESTINATAIRE
'NOUVEAU_MESSAGE.Subject = "Ci-joint: " & UserForm1.Label1.Caption
NOUVEAU_MESSAGE.Subject = "LE FICHIER: " & Right(UserForm1.Label1.Caption, _
                                         (Len(UserForm1.Label1.Caption) _
                                         - InStrRev(UserForm1.Label1.Caption, SLASH, -1)))
 
 
NOUVEAU_MESSAGE.TextBody = UserForm1.TextBox2.Value ' Les commentaires dans le corps du message.
NOUVEAU_MESSAGE.AddAttachment UserForm1.Label1.Caption ' Le Fichier joint
 
With NOUVEAU_MESSAGE.Configuration.Fields
.Item(CdoConfiguration.cdoSendUsingMethod) = 2
.Item(CdoConfiguration.cdoSMTPServer) = ADRESSE
 
.Update
 
End With
 
NOUVEAU_MESSAGE.Send
ENVOI_PAR_MAIL = True
MAIL_ENVOYE = ENVOI_PAR_MAIL 'Obligé d'utiliser la variable Public, sinon le Mail est envoyé deux fois!
Exit Function
 
ENVOI_PAR_MAIL_Err:
'MsgBox Err.Description 'Inactive, puisqu'inutile. Mais sans ce "GoTo" Plantage moi!
 
End Function

Dans l' USF:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub CommandButton1_Click() 'RECHERCHE DU FICHIER A ENVOYER
 
Dim RECHERCHE_FICHIER_A_ENVOYER As FileDialog
 
Set RECHERCHE_FICHIER_A_ENVOYER = Application.FileDialog(msoFileDialogFilePicker)
RECHERCHE_FICHIER_A_ENVOYER.AllowMultiSelect = False
RECHERCHE_FICHIER_A_ENVOYER.Show
 
For lngCount = 1 To RECHERCHE_FICHIER_A_ENVOYER.SelectedItems.Count
  SUJET = RECHERCHE_FICHIER_A_ENVOYER.SelectedItems(lngCount)
Next lngCount
 
On Error Resume Next ' EN CAS DE FERMETURE DE LA BOITE DE DIALOGUE SANS SELECTION
 
With UserForm1
.Label1.Caption = SUJET ' LE FICHIER A JOINDRE
.CommandButton1.Visible = False
.CommandButton2.Top = .CommandButton1.Top
.CommandButton2.Visible = True
End With
 
End Sub
 
Private Sub CommandButton2_Click() ' BOUTON "ENVOYER"
 
Dim REDACTION As String ' à mettre éventuellement en "Public" dans un module
 
UserForm1.WebBrowser1.Visible = True
UserForm1.CommandButton2.Visible = False
 
For i = 3 To 5 ' A ADAPTER SUIVANT LA STRUCTURE DU CARNET D'ADRESSE
                '(Il serait aussi intéressant de le charger dans une ListView, avec des cases à cocher)
 
DESTINATAIRE = Worksheets("ADRESSES").Cells(i, 2).Value
Call ENVOI_PAR_MAIL ' MODULE "ENVOI_MAILS"
 
If MAIL_ENVOYE = True Then
 
    REDACTION = "Les Mail ont été envoyés. Vous pouvez fermer l'USF ..."
 
Else
 
REDACTION = "Envoi Impossible. Vous êtes déconnecté, ou une adresse est Invalide"
 
End If
 
UserForm1.WebBrowser1.Navigate _
"about:<html><body><body scroll='no' bgcolor=#ffffff><width=100% height=100%>" _
& "<body topmargin=0><font color=  #dc143c & size='6' face='NEW'>" & _
"<MARQUEE>" & REDACTION & "<REDACTION align='top' ></marquee></font></body></html>"
 
Next i
End Sub
 
Private Sub UserForm_Initialize()
'Pour remplacer les Virgules par des Points dans les Adresses Mails.
Worksheets("ADRESSES").Activate
For v = 1 To 5
ActiveSheet.Cells(v, 2).Value = _
Replace(Replace(ActiveSheet.Cells(v, 2).Value, ",", "."), " ", ",")
Next v
ActiveWorkbook.Save
 
Dim REDACTION As String
REDACTION = "Merci de bien vouloir patienter"
 
UserForm1.WebBrowser1.Navigate _
"about:<html><body><body scroll='no' bgcolor=#ffffff><width=100% height=100%>" _
& "<body topmargin=0><font color=  #00008b & size='6' face='NEW'>" & _
"<MARQUEE>" & REDACTION & "<REDACTION align='top' ></marquee></font></body></html>"
 
UserForm1.WebBrowser1.Top = UserForm1.CommandButton1.Top
UserForm1.TextBox1.Value = Worksheets("ADRESSES").Cells(1, 2).Value ' VOTRE ADRESSE
 
End Sub
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    With WebBrowser1.Document.Body 'Pour ne pas voir la bordure du WebBrowser
        .Style.BorderStyle = "none"
        .Scroll = "no"
    End With
End Sub

Dans une feuille nommée "ADRESSES"

En B1: Votre Adresse Mail Personnelle
En B3, B4 et B5: L'adresse des destinataires.
(Conseil: mettez-y aussi la vôtre pour ne par envahir vos amis)
Et le bouton d'ouverture de l'UserForm1

J'espère ne rien avoir oublié.

Je joint un Classeur exemple, et espérant qu'il passe et reste. (Ce serait plus facile pour tester)

Si souci... Me le dire.

Bonne fin de journée et de fin de semaine.

Yann