Envoi de mail

Télécharger le projet
Commenter

Description

Cela permet d'envoyer un mail

Source / Exemple : 


Option Explicit

Private Enum SMTPSessionState
    SMTP_CONNECT
    SMTP_HELO
    SMTP_MAIL
    SMTP_RCPT
    SMTP_DATA
    SMTP_SENDMESSAGE
    SMTP_QUIT
End Enum

Private CurrentSMTPSessionState As SMTPSessionState

Private lcSenderDisplayName As String ' Copie locale
Private lcSenderAddress As String ' Copie locale
Private lcRecipientDisplayName As String ' Copie locale
Private lcRecipientAddress As String ' Copie locale
Private lcSubject As String ' Copie locale
Private lcMessage As String ' Copie locale

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

    Dim sServerResponse As String
    Dim sDataToSend As String
    Dim MessageLines() As String
    Dim i As Long

    ' Récupère la réponse du serveur
    Winsock1.GetData sServerResponse

    If Left(sServerResponse, 1) = "2" Or Left(sServerResponse, 1) = "3" Then

        Select Case CurrentSMTPSessionState
            Case SMTP_CONNECT

                ' Change l'état de la session
                CurrentSMTPSessionState = SMTP_HELO

                ' Récupère le nom de domaine
                sDataToSend = Right(lcSenderAddress, Len(lcSenderAddress) - InStr(lcSenderAddress, "@"))

                ' Envoie la commande HELO au serveur
                sDataToSend = "HELO " & sDataToSend & vbCrLf
                Winsock1.SendData sDataToSend

            Case SMTP_HELO

                ' Change l'état de la session
                CurrentSMTPSessionState = SMTP_MAIL

                ' Envoie la commande MAIL au serveur
                sDataToSend = "MAIL FROM:<" & lcSenderAddress & ">" & vbCrLf
                Winsock1.SendData sDataToSend

            Case SMTP_MAIL

                ' Change l'état de la session
                CurrentSMTPSessionState = SMTP_RCPT

                ' Envoie la commande RCPT au serveur
                sDataToSend = "RCPT TO:<" & lcRecipientAddress & ">" & vbCrLf
                Winsock1.SendData sDataToSend

            Case SMTP_RCPT

                ' Change l'état de la session
                CurrentSMTPSessionState = SMTP_DATA

                ' Envoie la commande DATA au serveur
                sDataToSend = "DATA" & vbCrLf
                Winsock1.SendData sDataToSend

            Case SMTP_DATA

                ' Change l'état de la session
                CurrentSMTPSessionState = SMTP_SENDMESSAGE

                ' Envoie les en-têtes du message
                Winsock1.SendData "Subject: " & lcSubject & vbLf
                Winsock1.SendData "From: " & Chr(34) & lcSenderDisplayName & Chr(34) & " <" & lcSenderAddress & ">" & vbLf
                Winsock1.SendData "To: " & Chr(34) & lcRecipientDisplayName & Chr(34) & " <" & lcRecipientAddress & ">" & vbLf

                ' Scinde le message en lignes
                MessageLines = Split(lcMessage, vbCrLf)

                ' Envoie chaque ligne du message
                For i = 0 To UBound(MessageLines)
                    sDataToSend = MessageLines(i)
                    If Left(sDataToSend, 1) = "." Then
                        sDataToSend = "." & sDataToSend
                    End If
                    Winsock1.SendData sDataToSend & vbLf
                Next

                ' Envoie un point pour indiquer la fin de l'envoie des données
                Winsock1.SendData vbCrLf & "." & vbCrLf

            Case SMTP_SENDMESSAGE

                MsgBox "Le message envoyé avec succès.", vbInformation

                ' Change l'état de la session
                CurrentSMTPSessionState = SMTP_QUIT

                ' Envoie la commande QUIT au serveur
                Winsock1.SendData "QUIT" & vbCrLf

            Case SMTP_QUIT

                ' Ferme la connexion
                Winsock1.Close

        End Select

    Else

        MsgBox "Erreur SMTP : " & sServerResponse, vbExclamation
        CurrentSMTPSessionState = SMTP_QUIT
        Winsock1.SendData "QUIT" & vbCrLf

    End If

End Sub

Private Sub Winsock1_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 "Winsock Error number " & Number & " : " & Description, vbExclamation
    Winsock1.Close

End Sub

Public Sub SendMail(SMTPServeur As String, SenderAddress As String, RecipientAddress As String, Subject As String, Message As String, Optional SenderDisplayName As String, Optional RecipientDisplayName As String)

    lcSenderDisplayName = Trim(SenderDisplayName)
    lcSenderAddress = Trim(SenderAddress)
    lcRecipientDisplayName = Trim(RecipientDisplayName)
    lcRecipientAddress = Trim(RecipientAddress)
    lcSubject = Trim(Subject)
    lcMessage = Trim(Message)

    CurrentSMTPSessionState = SMTP_CONNECT
    Winsock1.Connect Trim$(SMTPServeur), 25

End Sub

Private Sub Command1_Click()

    Call SendMail("Mon nom de serveur SMTP", Text6.Text, Text1.Text, Text3.Text, Text2.Text, Text4.Text, Text5.Text)

End Sub

Conclusion :


Il faut ajouter un control Winsock
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.