2 pièce(s) jointe(s)
VBA spam sur l'envoi automatique de mail
Bonjour,
je suis débutant sur VBA et je fais une macro sur excel qui permet de créer des comptes utilisateur. Cependant j'ai un problème avec l'envoi du mail de confirmation lors de la création du compte et sur le "mot de passe oublié". Voici mon code.
La première fois que j'ai lancé la macro on ma demander de configurer le mail, j'ai donc créé un mail outlook.fr pour envoyer les mail. Des fois ça fonctionne bien sauf que outlook semble considérer mes mails comme des spam est les bloque dans la boite de réception. A la fin du message je vous montre une capture écran de ce que j'ai sur ce mail outlook.fr.
Auriez vous une solution à ce problème? 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
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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
| Option Explicit
Private Sub creationcompte_Click()
Dim user As String ' c'est le nom d'utilisateur
Dim mdp As String ' c'est le mot de passe
Dim confirmation As String ' c'est le mot de passe entré pour confirmation
Dim mail As Variant ' sert à l'envoi du mail
Dim email As String ' email de l'utilisateur
Dim sendmail As Outlook.Application ' sert à l'envoi du mail
Dim createsheet As Worksheet ' sert à l'envoi du mail
Dim i As Long
Set sendmail = New Outlook.Application ' sert à l'envoi du mail
Set mail = sendmail.CreateItem(olMailItem) ' sert à l'envoi du mail
user = Me.textuser ' les variable prennent les valeurs entrées par l'utilisateur
mdp = Me.textmdp
confirmation = Me.textconf
email = Me.Textemail
If Range("user").Offset(1) <> "" Then
For i = 1 To Range("user").End(xlDown).Row - 1 'on cherche si le nom d'utilisateur existe déjà
If user = Range("user").Offset(i).Value Then 'si le nom d'utilisateur existe alors le message d'erreur s'affiche
Me.msgerreur.Caption = "Nom d'utilisateur déjà utilisé"
Me.msgerreur.Visible = True
Me.textuser = "" ' on vide la textbox
Exit Sub
ElseIf email = Range("user").Offset(i, 2).Value Then 'on regarde si le mail existe déjà
Me.msgerreur.Caption = "Email déjà enregistré"
Me.msgerreur.Visible = True
Me.Textemail = "" ' on vide la textbox
Exit Sub
End If
Next i
End If
If mdp = "" Or user = "" Or confirmation = "" Or email = "" Then ' gestion d'erreur, il faut remplir tout l'userform
Me.msgerreur.Visible = True
Me.msgerreur.Caption = "Veuillez remplir toutes les informations"
ElseIf mdp <> confirmation Then ' gestion d'erreur du mot de passe
Me.msgerreur.Visible = True
Me.msgerreur.Caption = "Vous n'avez pas saisi le même mot de passe"
Me.textconf = "" 'on vide les textbox
Me.textmdp = ""
Else
If MsgBox("Confirmez la création du compte", vbYesNo, "confirmation") = vbYes Then
' msgbox de confirmation de création du compte
If Range("user").Offset(1).Value = "" Then
' on note les données dans la feuille connexion, ici c'est dans le cas où c'est le premier compte créé
Range("user").Offset(1).Value = user
Range("user").Offset(1, 1).Value = mdp
Range("user").Offset(1, 2).Value = email
MsgBox ("compte créé")
Set createsheet = Sheets.Add(after:=Sheets(Sheets.Count)) 'création d'un nouvelle feuille pour ce nouveau compte
createsheet.Name = "base de donnée " & user 'le nom de la feuille prend le nom "base de donné " suivit du nom d'utilisateur
ThisWorkbook.Save
On Error GoTo erreurmail
With mail 'pour l'envoi du mail
.To = email ' le destinataire
.Subject = "Merci d'avoir créé votre compte" ' l'objet du mail
.Body = " Merci pour votre inscription, veuillez trouvez ci-dessous vos identifiants de connexion " & Chr(10) & " nom d'utilisateur: " & user & _
Chr(10) & "mot de passe: " & mdp 'le corps du mail ..son contenu
.Send ' l'envoie du mail
End With
sendmail.Quit
Set mail = Nothing
Set sendmail = Nothing
MsgBox ("Merci de votre inscription, vous recevrez un email dans quelques minutes")
Unload Me 'on décharge l'userform pour libérer de la mémoire
Else
'si un compte existe déjà alors on note les données en dessous sur la feuille connexion
Range("user").End(xlDown).Offset(1).Value = user
Range("user").End(xlDown).Offset(0, 1).Value = mdp
Range("user").End(xlDown).Offset(0, 2).Value = email
MsgBox ("compte créé")
Set createsheet = Sheets.Add(after:=Sheets(Sheets.Count)) 'création d'un nouvelle feuille pour ce nouveau compte
createsheet.Name = "base de donnée " & user 'le nom de la feuille prend le nom "base de donné " suivit du nom d'utilisateur
ThisWorkbook.Save
On Error GoTo erreurmail
With mail 'pour l'envoi du mail
.To = email ' le destinataire
.Subject = "Merci d'avoir créé votre compte" ' l'objet du mail
.Body = " Merci pour votre inscription, veuillez trouvez ci-dessous vos identifiants de connexion " & Chr(10) & " nom d'utilisateur: " & user & _
Chr(10) & "mot de passe: " & mdp 'le corps du mail ..son contenu
.Send ' l'envoie du mail
End With
sendmail.Quit
Set mail = Nothing
Set sendmail = Nothing
MsgBox ("Merci de votre inscription, vous recevrez un email dans quelques minutes")
Unload Me 'on décharge l'userform pour libérer de la mémoire
End If
Else
Unload Me 'on décharge l'userform pour libérer la mémoire si il choisi non pour la confirmation de création du compte
End If
End If
Exit Sub
erreurmail:
MsgBox ("compte crée mais erreur dans l'envoie de mail, vérifier votre connexion internet")
Unload Me 'on décharge l'userform pour libérer de la mémoire
End Sub |
