Anonym mail simple et expliqué (winsock + progressbar)

Télécharger le projet
Commenter

Description

Si vous voulez un example regarder la capture d'écran
Le code est pas compliké, y a aussi une bonne gestion de la barre de progression(lettres apres lettres)
Pour l'instant on peut envoyer qu'à une personne

Source / Exemple : 


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

Conclusion :


pour envoyer un mail:
-vous devez au moins remplir le champ serveur et l'adresse du destinataire
-le serveur SMTP doit etre celui qu'utilise le destinataire (pour bidule@wandoo.fr utiliser le serveur de wanadoo: mail.wanadoo.fr) ou alors un serveur "open relay" (c'est deja plus dur à trouver)

Je me suis pas renseigné assez mais pour ma part le serveur SMTP de monfournisseur me permet d'envoyer des mails à n'importe quels e-mail... Testez avec le votre...
Si vous avez d'autres questions ou peut etre des suggestions envoyer moi un message
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.

Du même auteur (cs_Repie)