Attribute VB_Name = "ClientSMTP"
Option Explicit

'############# VARIABLES PUBLIQUES (gloables) ######################
'Adresse du Serveur SMTP
Public AdresseSMTP As String

'Adresse mail de l'expéditeur du mail
Public EMailUser As String

'Pour recevoir un copie des mails envoyés
Public CopieMailSend As Boolean


'Liste des fichiers attachés au mail
Public tabFileAttach() As fileAttach

'Nombre de fichier attaché au mail (255 Maximum !)
Public nbFileAttach As Byte

'Taille des fichiers attachés au mail en octets
Public nbSizeFileAttach As Long

'Permet d'arrêter la communication en cours avec le serveur SMTP
Public StopClientSMTP As Boolean

'Message d'erreur
Public strErreurSMTP As String


'############# AUTRES VARIABLES (privées <--> locales à ce module) ###############################
Private Type fileAttach
    Path As String
    name As String
    Size As Long 'Taille en Ko du fichier
End Type

'Etape du dialogue avec le serveur dans le protocole SMTP
Dim Stat As Byte

'Liste des adresses mails des destinataires
Dim lstDestinataireMail() As String

'Nombre de destinataire du mail
Dim NbDestinataire As Byte

'Adresse mail de l'expéditeur
Dim strExpediteurMail As String

'Sujet du mail
Dim strSubject As String

'Contenu du mail
Dim strBody As String

'True quand la connexion avec le serveur SMTP est active
Dim isConnect As Boolean

'True si le mail a été envoyé avec succès
Dim isSend As Boolean

'Compteur parcourant la liste des adresses mails des destinataires
Dim cptDest As Byte



'#####################################################################################
'# ENVOI DE PLUSIEURS MAILS DANS LA MEME SESSION SMTP (1 SEUL OUVERTURE DU SERVEUR)  #
'#####################################################################################

' ************************************************************************************
' *                                                                                  *
' * Se connecte au serveur SMTP dont l'adresse est contenu dans 'AdresseSMTP'        *
' *                                                                                  *
' *                                                                                  *
' ************************************************************************************
Public Function ConnectToServeurSMTP() As Boolean
    
    'Connexion au serveur SMTP
    If initialiseWinSock() Then
        ConnectToServeurSMTP = True
        fMainForm.StatusBar1.Panels(1).Text = "Envoi du mail en cours..."
    Else
        ConnectToServeurSMTP = False
    End If
    
End Function


' ************************************************************************************
' *                                                                                  *
' * Envoi un mail avec un fichier attaché à une liste de destinataires.              *
' * (la connexion SMTP avec le serveur étant déjà ouverte)                           *
' *                                                                                  *
' * Paramètre(s) :                                                                   *
' *    - strMailExpediteur : Adresse mail de l'expéditeur                            *
' *    - lstMailDestinataire : Liste des adresses mail des destinataires             *
' *    - nbDestinataireMail : Nombre de destinataires pour ce mail                   *
' *    - strSubjectMail : Sujet du mail                                              *
' *    - strBodyMail : Corp du mail (contenu)                                        *
' *    - strFileNameMail : Nom du fichier à joindre au mail                          *
' *    - strFileMail : Flux mémoire contenant le fichier à joindre                   *
' *                                                                                  *
' ************************************************************************************

Public Function SendMail(ByRef strMailExpediteur As String, _
                        ByRef lstMailDestinataire() As String, _
                        ByRef nbDestinataireMail As Byte, _
                        ByRef strSubjectMail As String, _
                        ByRef strBodyMail As String _
                        ) As Boolean
        
    SendMail = False
    StopClientSMTP = False
    
    On Error GoTo ErrorHandler
    
    strExpediteurMail = strMailExpediteur
    Call initListdestinataire(lstMailDestinataire(), nbDestinataireMail)
    NbDestinataire = nbDestinataireMail
    strSubject = strSubjectMail
    strBody = strBodyMail
    
    'Initialisation des variables pour la communication avec le serveur SMTP
    Stat = 2
    isSend = False
    cptDest = 0
    strErreurSMTP = ""
    StopClientSMTP = False
    
    'adresse de l'utilisateur (source du message)
    fMainForm.WinsockMail.SendData "MAIL FROM:<" + strExpediteurMail + ">" + vbCrLf
    
    'boucle pendant la communication SMTP
    Do While Not isSend And strErreurSMTP = "" And (Not StopClientSMTP)
        DoEvents
    Loop
    
    If isSend And strErreurSMTP = "" And (Not StopClientSMTP) Then
        SendMail = True
    End If
    
    StopClientSMTP = True
    
    Exit Function
ErrorHandler:
    strErreurSMTP = "Erreur Winsock inattendue."
    SendMail = False
End Function

' ************************************************************************************
' *                                                                                  *
' * Ferme la connexion en cours avec le serveur SMTP                                 *
' *                                                                                  *
' *                                                                                  *
' ************************************************************************************
Public Sub CloseConnectionSMTP()
    On Error Resume Next
    
    fMainForm.WinsockMail.SendData "QUIT" + vbCrLf
    DoEvents
    
    fMainForm.WinsockMail.Close
    StopClientSMTP = True
    DoEvents
End Sub



'Initialise la liste des adresses mails des destinataires
Private Sub initListdestinataire(ByRef lstMailDestinataire() As String, ByRef nbDest As Byte)
    Dim i As Byte
    
    ReDim lstDestinataireMail(nbDest)
    
    i = 0
    Do While i < nbDest
        lstDestinataireMail(i) = lstMailDestinataire(i)
        i = i + 1
    Loop
End Sub



' #####################################
' # Initialise la connexion WINSOCK   #
' #####################################

Private Function initialiseWinSock() As Boolean
    On Error GoTo ErrorHandler
    
    Stat = 0
    isConnect = False
    strErreurSMTP = ""
    StopClientSMTP = False
    
    fMainForm.WinsockMail.Close
    DoEvents
    fMainForm.WinsockMail.RemotePort = 25
    fMainForm.WinsockMail.RemoteHost = AdresseSMTP
    fMainForm.WinsockMail.Connect 'on se connecte au server SMTP
    
    'boucle pendant l'établissement de la connexion avec le serveur SMTP
    Do While (Not isConnect) And strErreurSMTP = "" And (Not StopClientSMTP)
        DoEvents
    Loop
    
    If strErreurSMTP = "" And Not StopClientSMTP Then
        initialiseWinSock = True
    Else
        initialiseWinSock = False
        If StopClientSMTP Then
            strErreurSMTP = "La connexion avec le serveur SMTP a été interrompue."
        End If
    End If

    Exit Function
ErrorHandler:
    initialiseWinSock = False
    strErreurSMTP = "La connexion avec le serveur SMTP a été interrompue :" + """" + AdresseSMTP + """."
End Function

' ####################################################
' # Envoie par mail le fichier                       #
' ####################################################

Private Function SendFile() As Boolean
    On Error GoTo ErrorSend
    
    'Initialise la connexion avec le serveur SMTP
    If Not initialiseWinSock() Then
        SendFile = False
        fMainForm.WinsockMail.Close
        Exit Function
    End If
    
    'Initialisation des variables
    Stat = 2
    isSend = False
    cptDest = 0
    strErreurSMTP = ""
    StopClientSMTP = False
    
    'adresse de l'utilisateur (source du message)
    fMainForm.WinsockMail.SendData "MAIL FROM:<" + strExpediteurMail + ">" + vbCrLf
    
    'boucle pendant la communication SMTP
    Do While Not isSend And strErreurSMTP = "" And (Not StopClientSMTP)
        DoEvents
    Loop
    
    If isSend And strErreurSMTP = "" And (Not StopClientSMTP) Then
        SendFile = True
    Else
        SendFile = False
    End If
    
    'Ferme la connexion
    isConnect = False
    'Ferme la Socket de communication
    fMainForm.WinsockMail.Close
    
    Exit Function
ErrorSend:
    strErreurSMTP = "Erreur Winsock inattendue."
    'Ferme la connexion
    isConnect = False
    'Ferme la Socket de communication
    fMainForm.WinsockMail.Close
End Function


' ############################################################
' # Ajoute l'header SMTP pour l'attachement d'un fichier      #
' # (FORMAT MIME)                                             #
' ############################################################
Private Function AddHeaderFileSMTP() As String
    Dim i As Byte
    Dim strFileNameSend As String
    Dim strFile As String
    Const Boundary As String = "BaliseMIME"
    
    AddHeaderFileSMTP = "MIME-Version: 1.0" + vbCrLf + _
                "Content-Type: multipart/mixed; " + _
                "boundary=" + """" + "----=_" + Boundary + """" + vbCrLf + _
                "X-Mailer: Jock VB" + vbCrLf + vbCrLf + _
                "This is a multi-part message in MIME format." + vbCrLf + vbCrLf

    AddHeaderFileSMTP = AddHeaderFileSMTP + _
                    "------=_" + Boundary + vbCrLf + _
                    "Content-Type: text/plain; charset=" + """" + "iso-8859-1" + """" + vbCrLf + _
                    "Content-Transfer-Encoding: 8bit" + vbCrLf + vbCrLf

    
    'Contenu du mail
    AddHeaderFileSMTP = AddHeaderFileSMTP + _
                    strBody + vbCrLf + vbCr + vbCrLf + vbCrLf
    
   
       
    '************************'
        
    If nbFileAttach = 0 Then
        Exit Function
    End If
            
    i = 0
    Do While i < nbFileAttach
                
        strFile = OpenFileAPI(tabFileAttach(i).Path)
        
        If strFile = "" Then
        'Erreur d'ouverture du fichier à attacher au mail
            strErreurSMTP = "Impossible d'ouvrir le fichier suivant :" + vbCrLf + _
                            """" + tabFileAttach(i).Path + """."
            DoEvents
            Exit Function
        End If
            
        strFileNameSend = tabFileAttach(i).name

        AddHeaderFileSMTP = AddHeaderFileSMTP + _
                            "------=_" + Boundary + vbCrLf + _
                            "Content-Type: application/octet-stream;" + vbCrLf + _
                            "   name=" + """" + strFileNameSend + """" + vbCrLf + _
                            "Content-Transfer-Encoding: base64" + vbCrLf + _
                            "Content-Disposition: attachment;" + vbCrLf + _
                            "   filename=" + """" + strFileNameSend + """" + vbCrLf + vbCrLf
            
        'Encode le fichier en base64 et l'ajoute au mail
        AddHeaderFileSMTP = AddHeaderFileSMTP + _
                            Encode64(strFile) + vbCrLf
            
        i = i + 1
    Loop

    AddHeaderFileSMTP = AddHeaderFileSMTP + _
                        "------=_" + Boundary + vbCrLf
                        
    Debug.Print AddHeaderFileSMTP
End Function


' #####################################################
' # Communication SMTP (winsock) avec le serveur SMTP #
' #                                                   #
' #####################################################
Public Sub ProcessDataArrivalSMTP(ByRef strData As String)
    Dim strDestinataire As String
    
    On Error GoTo ErrorWinSock

    Select Case Stat
    
    '------------------------- Connexion au serveur SMTP -------------------------------
    Case 0
        'Tentative de connexion au serveur
        If Left$(strData, 3) = "220" Then
            fMainForm.WinsockMail.SendData "HELO " + fMainForm.WinsockMail.LocalHostName + vbCrLf
        Else
            strErreurSMTP = Left$(strData, 3) + "- Impossible de se connecter au serveur SMTP" + """" + AdresseSMTP + """."
        End If
        
        
    Case 1
        If Not Left$(strData, 3) = "250" Then
            strErreurSMTP = Left$(strData, 3) + "- Connexion refusée par le serveur SMTP" + """" + AdresseSMTP + """."
        Else
            isConnect = True
        End If
        Exit Sub
        
        
    '------------------------------ Envoie du mail --------------------------------------
    Case 2
        'adresse du destinataire
        If Left$(strData, 3) = "250" Then

            Do While cptDest < NbDestinataire
                fMainForm.WinsockMail.SendData "RCPT TO:<" + lstDestinataireMail(cptDest) + ">" & vbCrLf
                cptDest = cptDest + 1
                Stat = 1
                Exit Do
            Loop
            
            'Toutes les adresse mail des destinataires ont été communiquées au serveur SMTP
            If Stat = 2 Then
                fMainForm.WinsockMail.SendData "DATA" & vbCrLf
                Stat = 4
                Exit Sub
            End If
    
        Else
            If cptDest > 1 Then
                strErreurSMTP = Left$(strData, 3) + "- Adresse mail de " + " """ + lstDestinataireMail(cptDest - 1) + """ " + "non reconnu par le serveur SMTP" + " """ + AdresseSMTP + """."
            Else
                strErreurSMTP = Left$(strData, 3) + "- Votre adresse mail n'est pas reconnu par le serveur SMTP" + " """ + AdresseSMTP + """."
            End If
        End If


    Case 3
        If Left$(strData, 3) = "250" Then 'données
            fMainForm.WinsockMail.SendData "DATA" + vbCrLf
        Else
            strErreurSMTP = Left$(strData, 3) + "- Adresse mail du destinataire non reconnu par le serveur SMTP" + " """ + AdresseSMTP + """."
        End If


    Case 4
        'Envoie des données
        If Left$(strData, 3) = "354" Then 'on envoi le mail
            
            cptDest = 0
            'Expéditeur
            fMainForm.WinsockMail.SendData "From: <" + strExpediteurMail + ">" + vbCrLf
            DoEvents
            
            strDestinataire = "To: "
            'Mail des destinataires
            Do While cptDest < NbDestinataire - 1
                strDestinataire = strDestinataire + _
                                    "<" + lstDestinataireMail(cptDest) + ">," & vbCrLf & Chr$(9)
                cptDest = cptDest + 1
            Loop
            strDestinataire = strDestinataire + _
                            "<" + lstDestinataireMail(cptDest) + ">"
                      
            'Destinataires
            fMainForm.WinsockMail.SendData strDestinataire + vbCrLf
            DoEvents
            
            'Sujet
            fMainForm.WinsockMail.SendData "Subject: " + FormatMIME(strSubject) + vbCr + vbCrLf
            DoEvents
            
            'Contenu du mail
            fMainForm.WinsockMail.SendData AddHeaderFileSMTP() + vbCrLf + "." + vbCrLf
            DoEvents
            
        Else
            strErreurSMTP = Left$(strData, 3) + "- Erreur lors de l'envoi de l'en-tête du mail."
        End If


    Case 5
        If Left$(strData, 3) <> "250" Then
            'Erreur d'envoie du mail
            strErreurSMTP = Left$(strData, 3) + "- Erreur lors de l'envoie du contenu du mail."
        Else
            'Mail envoyé OK
            isSend = True
        End If
        
    End Select
    
    Stat = Stat + 1
    
    Exit Sub
ErrorWinSock:
    strErreurSMTP = "Erreur n°" + CStr(Err.Number) + vbCrLf + Err.Description
End Sub

Public Sub WinSockSMTP_Error(Number As Integer, Description As String)
    
    Select Case Number
        Case 11001
            strErreurSMTP = "Impossible de se connecter au serveur SMTP" + """" + AdresseSMTP + """."
         Case 11004
            strErreurSMTP = "Impossible de se connecter au serveur SMTP" + """" + AdresseSMTP + """."
        Case 10060
            strErreurSMTP = "Impossible d'accéder au serveur SMTP." + vbCrLf + "Vérifiez votre connexion réseau ou internet."
        Case 10071
            strErreurSMTP = "Impossible de se connecter au serveur SMTP" + """" + AdresseSMTP + """."
        Case Else
            strErreurSMTP = Err.Description
    End Select
    
    fMainForm.WinsockMail.Close
End Sub


'Retourne une chaine au format MIME
Private Function FormatMIME(ByRef strText As String) As String
    Dim car As String * 1
    Dim i As Long 'Pointeur strText
    
    On Error GoTo ErrorHandler
    
    FormatMIME = "=?iso-8859-1?Q?"
    
    i = 0
    Do While i < Len(strText)
        car = Mid$(strText, i + 1, 1)
        
        If Asc(car) < 127 Then
            If car = " " Then
                FormatMIME = FormatMIME + "_"
            Else
                FormatMIME = FormatMIME + car
            End If
        Else
            FormatMIME = FormatMIME + "=" + Hex$(Asc(car))
        End If
        
        i = i + 1
    Loop
    
    FormatMIME = FormatMIME + "?="
    
    Exit Function
ErrorHandler:
    FormatMIME = strText
End Function
