Soyez le premier à donner votre avis sur cette source.
Vue 14 730 fois - Téléchargée 1 589 fois
dans le module ------------------ Option Explicit Public Type Retour valeur As Boolean libelle As String End Type Public Function Vérification_Champs() As Retour Dim temp As Retour temp.valeur = False If F.Text_Serveur.Text = "" Then temp.libelle = "Vous devez remplir le champ [Serveur]": Vérification_Champs = temp: Exit Function If F.Text_Mail_Dest.Text = "" Then temp.libelle = "Vous devez remplir le champ du [Mail Destinataire]": Vérification_Champs = temp: Exit Function temp.valeur = True Vérification_Champs = temp End Function Public Function Recup(ByVal temp As String, code As Integer) As Boolean If Val(Mid(temp, 1, 3)) = code Then Recup = True Else Recup = False End If End Function Dans la frame ----------------- Dim Etape As Integer Dim Erreur As Boolean Private Sub Command1_Click() Dim ret Dim temp As Retour Erreur = False MousePointer = fmMousePointerAppStarting temp = Vérification_Champs If temp.valeur = False Then 'Erreur ret = MsgBox(temp.libelle, vbCritical, "Erreur") MousePointer = fmMousePointerDefault Else 'On met en forme les données Etape = 0 If Not W.State = 0 Then W.Close DoEvents W.RemoteHost = Text_Serveur.Text W.Connect End If End Sub Private Sub Form_Load() W.RemotePort = 25 W.LocalPort = 1003 Bar.max = 60 End Sub Private Sub W_DataArrival(ByVal bytesTotal As Long) Dim Temp_Recep, Temp_Envoi As String Dim ret W.GetData Temp_Recep, vbString Select Case Etape Case 0 If Recup(Temp_Recep, 220) Then '''''''''''' Recup du nom du serveur pour la commande "HELO {Nom du serveur}" Temp_Envoi = "HELO " & Text_Serveur Envoyer (Temp_Envoi) Else MsgBox ("Problème lors de la Connexion" & vbCrLf & Temp_Recep) MousePointer = fmMousePointerDefault End If Case 1 'On est connecté et on a envoyer "HELO {Nom du serveur}" If Recup(Temp_Recep, 250) Then '''''''''''' Le Helo est bien pris en compte et on peux commencer à envoyer... Temp_Envoi = "MAIL FROM: " & "<" & Text_Mail_Emet & ">" Envoyer (Temp_Envoi) Else '''''''''''' Le HELO est rejeté MsgBox ("Problème lors de la réponse au HELO" & vbCrLf & Temp_Recep) MousePointer = fmMousePointerDefault End If Case 2 If Recup(Temp_Recep, 250) Then '''''''''''' Le MAIL FROM: est accepté Temp_Envoi = "RCPT TO: " & "<" & Text_Mail_Dest & ">" Envoyer (Temp_Envoi) Else '''''''''''' Le MAIL FROM: n'est pas accepté MsgBox ("Problème lors de la réponse au MAIL FROM" & vbCrLf & Temp_Recep) MousePointer = fmMousePointerDefault End If Case 3 If Recup(Temp_Recep, 250) Then '''''''''''' Le RCPT est accepté, on a fait le plus dur ;) Temp_Envoi = "DATA" Envoyer (Temp_Envoi) Else '''''''''''' Le serveur n'est pas open relay ou alors le destinataire est inconnu MsgBox ("Problème lors de la réponse au RCPT TO" & vbCrLf & Temp_Recep) MousePointer = fmMousePointerDefault End If Case 4 If Recup(Temp_Recep, 354) Then Temp_Envoi = "" '''''''''''' Remplir les champs correspondant à l'emetteur If Not Text_Nom_Emet = "" Or Not Text_Mail_Emet = "" Then Temp_Envoi = "From: " If Not Text_Nom_Emet = "" Then Temp_Envoi = Temp_Envoi & Chr(34) & Text_Nom_Emet & Chr(34) & " " If Not Text_Mail_Emet = "" Then Temp_Envoi = Temp_Envoi & "<" & Text_Mail_Emet & ">" Temp_Envoi = Temp_Envoi & vbCrLf End If ''''''''''' Remplir les champs correspondant au destinataire Temp_Envoi = Temp_Envoi & "To: " If Not Text_Nom_Dest = "" Then Temp_Envoi = Temp_Envoi & Chr(34) & Text_Nom_Dest & Chr(34) & " " Temp_Envoi = Temp_Envoi & "<" & Text_Mail_Dest & ">" & vbCrLf ''''''''''' Ajouter le sujet du mail Temp_Envoi = Temp_Envoi & "Subject: " & Text_Sujet & vbCrLf & vbCrLf '2 sauts de lignes pour dire que l'on passe au corps du msg ''''''''''' Ajouter le corps du message Temp_Envoi = Temp_Envoi & Text_Msg & vbCrLf & "." ''''''''''' On Envoie tout Envoyer (Temp_Envoi) Else MsgBox ("Problème lors de la réponse au DATA" & vbCrLf & Temp_Recep) MousePointer = fmMousePointerDefault End If Case 5 If Not Recup(Temp_Recep, 250) Then ''''''' Si pb lors de la fin du message MsgBox ("Problème lors de la fin du corps du message" & vbCrLf & Temp_Recep) MousePointer = fmMousePointerDefault Else ''''''' Le message a bien été envoyé ;) C po cool ca? End If Envoyer ("QUIT") Case 6 If Recup(Temp_Recep, 221) Then If Not Erreur Then ret = MsgBox("Merci pour ce gentil programme" & vbCrLf & "qui m'a permis d'envoyer un" & vbCrLf & "E-mail @nonyme ;)", vbInformation, "Fin") Else MsgBox ("Problème lors de la déconnexion du serveur" & vbCrLf & Temp_Recep) End If Etape = -1 W.Close MousePointer = fmMousePointerDefault End Select Etape = Etape + 1 End Sub Private Sub W_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean) MsgBox (Description) If W.State = 7 Then ''''''' Pour pas avoir le message MErci pour ce gentil prog.... Erreur = True Envoyer ("quit") DoEvents Etape = 6 Else W.Close End If MousePointer = fmMousePointerDefault End Sub Public Function Envoyer(temp As String) Dim i, max, max_bar, comp_bar, delta_bar ''''''''''' on envoi les lettres une à une et en mm temps on fait progresser la barre1 max = Len(temp) Bar.Value = Etape * 10 delta_bar = 10 / Len(temp) For i = 1 To max Step 1 W.SendData (Mid(temp, i, 1)) Bar.Value = Bar.Value + delta_bar Next i W.SendData (vbCrLf) End Function
Pour ma part j'envoi "QUIT" au serveur, j'attend qu'il me déconnecte, PUIS dans sck_OnClose il faut faire sck.CloseSocket (ou .Close avec winsock).
Sinon la connexion reste dans l'état sckClosing.
Et la plus de problème.
Connais-tu un moyen pour éviter ce probleme de "address in use"? C'est chiant, j'essaye de mettre un mail anonyme mais le temps que j'en trouve une qui est acceptée par le serveur, une lettre de la poste à le temps d'arriver...
Dommage qu'on doive spécifier le serveur smtp mais bon, c'est la vie !
Bonne continuation
++
(et en regardant mon code g l'impression d'avoir pris en compte cette erreur puisque j'ai mis
If Not W.State = 0 Then W.Close)
Dans le form_load
il faut mettre en premier
W.Close
Et oui, autrement si ya le moindre problème
La barre de progressement s'arrête en plein milieu et il est impossible d'envoyer un mail pendant plus de 10min selon le serveur utilisé...
Il affiche l'erreur: "address in use"
(Cf cours Winsock étape1 sur http://grafikm.developpez.com/vbreseau/ )
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.