ANONYM MAIL SIMPLE ET EXPLIQUÉ (WINSOCK + PROGRESSBAR)

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