VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CSMTP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'programmed by ShareVB
Option Explicit

Private Const ERROR_NO_MORE_ITEMS As Long = 259&
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Declare Function FormatMessage Lib "kernel32.dll" Alias "FormatMessageA" (ByVal dwFlags As Long, ByRef lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByRef Arguments As Long) As Long

Private Declare Function getCRAM_MD5 Lib "Auth.dll" ( _
        ByVal szUsername As String, _
        ByVal szPassword As String, _
        ByVal szGreeting As String, _
        ByVal szOutBuffer As String, _
        ByRef cbszBuffer As Long) As Long
Private Declare Function get_DIGEST_MD5 Lib "Auth.dll" ( _
        ByVal szHost As String, _
        ByVal szUser As String, _
        ByVal szPasswd As String, _
        ByVal szRealm As String, _
        ByVal szServerChallenge As String, _
        ByVal szOutBuffer As String, _
        ByRef cbszBuffer As Long) As Long

Private Declare Function get_PLAIN Lib "Auth.dll" ( _
        ByVal szAuthorizeId As String, _
        ByVal szAuthenticateId As String, _
        ByVal szPasswd As String, _
        ByVal szOutBuffer As String, _
        ByRef cbszBuffer As Long) As Long

Private Declare Function get_LOGIN_login Lib "Auth.dll" ( _
        ByVal szLogin As String, _
        ByVal szOutBuffer As String, _
        ByRef cbszBuffer As Long) As Long
Private Declare Function get_LOGIN_passwd Lib "Auth.dll" ( _
        ByVal szPasswd As String, _
        ByVal szOutBuffer As String, _
        ByRef cbszBuffer As Long) As Long
        
'variables locales de stockage des valeurs de propriétés
Private mvarSMTPServer As String 'copie locale
Private mvarSMTPPort As Long 'copie locale
Private mvardomain As String 'copie locale
'authentification smtp
Private mvarAUTH As String 'copie locale
Private mvarUserName As String 'copie locale
Private mvarPassword As String 'copie locale

Private WS As CWinsock
Private SMTP As CSocket
Private bSecure As Boolean

Public Event Logging(ByVal szText As String)

'==================================================
'méthodes privées
'==================================================

Private Function WaitResult() As String
Dim buff As String, cb As Long, lcb As Long
Dim ret As Long, bLastLine As Boolean, pos As Long

bLastLine = False
Do
    cb = 200
    buff = Space(cb)
    lcb = 0
    ret = SMTP.ReadStringData(buff, cb, lcb)
    DoEvents
    If lcb Then
        buff = Mid$(buff, 1, lcb)
        WaitResult = WaitResult & buff
        
        If (Mid$(WaitResult, 4, 1) = " ") And (Mid$(WaitResult, Len(WaitResult) - 1, 2) = vbCrLf) Then
            bLastLine = True
        Else
            pos = 1
            Do
                pos = InStr(pos + 1, WaitResult, vbCrLf)
                If pos + 5 <= Len(WaitResult) Then
                    bLastLine = (Mid$(WaitResult, pos + 5, 1) = " ")
                End If
            Loop While pos And Not bLastLine
        End If
    End If
Loop Until bLastLine
End Function

Private Function ExecuteCommand(szCommand As String) As String
Dim lw As Long

If SMTP.WriteStringData(szCommand & vbCrLf, Len(szCommand) + 2, lw) <> 0 Then Exit Function

ExecuteCommand = WaitResult
End Function

Private Function GetStatusCode(szStatus As String, Optional szLog As String) As Long
    On Local Error Resume Next
    
    GetStatusCode = CLng(Val(Mid$(szStatus, 1, 3)))
    If Not IsMissing(szLog) Then
        szLog = Trim$(Mid$(szStatus, 5))
    End If
End Function

'==================================================
'méthodes publiques
'==================================================

Public Function FormatError(ByVal errCode As Long) As String
Dim l As Long
FormatError = Space(256)
l = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0&, errCode, 0&, FormatError, 256, ByVal 0&)
FormatError = Mid$(FormatError, 1, l)
End Function

Public Function TestServer() As Boolean
Dim serv As New CHost

TestServer = (serv.gethostbyname(mvarSMTPServer) = 0)
End Function

Public Function VerifyMail(ByVal szMail As String, Optional szSMTPServerStatus As String) As Long
'
End Function

Public Function SendMail(ByVal objMail As CMail, Optional szSMTPServerStatus As String) As Long
Dim addr As CMailAddress, buff() As String, ub As Long, l As Long, szCommand As String, szLog As String

Set SMTP = WS.CreateTCPSocket

RaiseEvent Logging("Connecting to " & mvarSMTPServer & " on port " & mvarSMTPPort & "...")

SendMail = SMTP.connectbyname(mvarSMTPServer, mvarSMTPPort)
If SendMail <> 0 Then
    RaiseEvent Logging("Failed to connect.")
    szSMTPServerStatus = szLog: GoTo Quit
End If

RaiseEvent Logging("Connected to server.")

SendMail = GetStatusCode(WaitResult, szLog)

RaiseEvent Logging(szLog)

If SendMail <> 220 Then szSMTPServerStatus = szLog: GoTo Quit

szCommand = "EHLO " & mvardomain
RaiseEvent Logging("Sending " & szCommand & " command...")
SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
RaiseEvent Logging(szLog)

If SendMail <> 250 Then szSMTPServerStatus = szLog: GoTo Quit

If bSecure Then
    szCommand = "STARTTLS"
    RaiseEvent Logging("Sending " & szCommand & " command...")
    SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
    RaiseEvent Logging(szLog)
    
    SMTP.BeginSecure "mycert.pem", "", "root.pem", vbNullString
End If

Select Case mvarAUTH
    Case "LOGIN"
        szCommand = "AUTH LOGIN"
        RaiseEvent Logging("Sending " & szCommand & " command...")
        SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
        RaiseEvent Logging(szLog)
        
        If SendMail <> 334 Then szSMTPServerStatus = szLog: GoTo Quit
    
        Call get_LOGIN_login(mvarUserName, vbNullString, l)
        szCommand = Space(l)
        l = l + 1
        Call get_LOGIN_login(mvarUserName, szCommand, l)
        
        RaiseEvent Logging("Sending username " & szCommand & " in base64...")
        SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
        RaiseEvent Logging(szLog)
        
        If SendMail <> 334 Then szSMTPServerStatus = szLog: GoTo Quit
    
        Call get_LOGIN_passwd(mvarPassword, vbNullString, l)
        szCommand = Space(l)
        l = l + 1
        Call get_LOGIN_passwd(mvarPassword, szCommand, l)
        
        RaiseEvent Logging("Sending password " & szCommand & " in base64...")
        SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
        RaiseEvent Logging(szLog)
        
        If SendMail <> 235 Then szSMTPServerStatus = szLog: GoTo Quit
    Case "PLAIN"
        szCommand = "AUTH PLAIN"
        RaiseEvent Logging("Sending " & szCommand & " command...")
        SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
        RaiseEvent Logging(szLog)
        
        If SendMail <> 334 Then szSMTPServerStatus = szLog: GoTo Quit
    
        Call get_PLAIN(mvarUserName, mvarUserName, mvarPassword, vbNullString, l)
        szCommand = Space(l)
        l = l + 1
        Call get_PLAIN(mvarUserName, mvarUserName, mvarPassword, szCommand, l)
        
        RaiseEvent Logging("Sending plain authentification " & szCommand & " in base64...")
        SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
        RaiseEvent Logging(szLog)
        
        If SendMail <> 235 Then szSMTPServerStatus = szLog: GoTo Quit
    Case "DIGEST-MD5"
        szCommand = "AUTH DIGEST-MD5"
        RaiseEvent Logging("Sending " & szCommand & " command...")
        SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
        RaiseEvent Logging(szLog)
        
        If SendMail <> 334 Then szSMTPServerStatus = szLog: GoTo Quit
    
        Call get_DIGEST_MD5(mvarSMTPServer, mvarUserName, mvarPassword, vbNullString, szLog, vbNullString, l)
        szCommand = Space(l)
        l = l + 1
        Call get_DIGEST_MD5(mvarSMTPServer, mvarUserName, mvarPassword, vbNullString, szLog, szCommand, l)
        RaiseEvent Logging("Sending digest-md5 authentification " & szCommand & " in base64...")
        SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
        RaiseEvent Logging(szLog)
        SendMail = GetStatusCode(ExecuteCommand(""), szLog)
        RaiseEvent Logging(szLog)
        
        If SendMail <> 235 Then szSMTPServerStatus = szLog: GoTo Quit
    Case "CRAM-MD5"
        szCommand = "AUTH CRAM-MD5"
        RaiseEvent Logging("Sending " & szCommand & " command...")
        SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
        RaiseEvent Logging(szLog)
        
        If SendMail <> 334 Then szSMTPServerStatus = szLog: GoTo Quit
    
        Call getCRAM_MD5(mvarUserName, mvarPassword, szLog, vbNullString, l)
        szCommand = Space(l)
        l = l + 1
        Call getCRAM_MD5(mvarUserName, mvarPassword, szLog, szCommand, l)
        RaiseEvent Logging("Sending cram-md5 authentification " & szCommand & " in base64...")
        SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
        RaiseEvent Logging(szLog)
        
        If SendMail <> 235 Then szSMTPServerStatus = szLog: GoTo Quit
End Select

With objMail.MailHeader
    If .From.Count = 0 Then SendMail = 550: szSMTPServerStatus = szLog: GoTo Quit
    
    szCommand = "MAIL FROM:" & .From.Item(1).MakeSMTP
    RaiseEvent Logging("Sending " & szCommand & " command...")
    SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
    RaiseEvent Logging(szLog)
    
    If SendMail <> 250 Then szSMTPServerStatus = szLog: GoTo Quit
    
    If .MailTo.Count = 0 Then SendMail = 550: szSMTPServerStatus = szLog: GoTo Quit

    For Each addr In .MailTo
        szCommand = "RCPT TO:" & addr.MakeSMTP
        RaiseEvent Logging("Sending " & szCommand & " command...")
        SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
        RaiseEvent Logging(szLog)
        
        If (SendMail <> 250) And (SendMail <> 251) Then szSMTPServerStatus = szLog: GoTo Quit
    Next
    
    If .Cc.Count Then
        For Each addr In .Cc
            szCommand = "RCPT TO:" & addr.MakeSMTP
            RaiseEvent Logging("Sending " & szCommand & " command...")
            SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
            RaiseEvent Logging(szLog)
        
            If (SendMail <> 250) And (SendMail <> 251) Then szSMTPServerStatus = szLog: GoTo Quit
        Next
    End If
    
    If .Bcc.Count Then
        For Each addr In .Bcc
            szCommand = "RCPT TO:" & addr.MakeSMTP
            RaiseEvent Logging("Sending " & szCommand & " command...")
            SendMail = GetStatusCode(ExecuteCommand(szCommand), szLog)
            RaiseEvent Logging(szLog)
            
            If (SendMail <> 250) And (SendMail <> 251) Then szSMTPServerStatus = szLog: GoTo Quit
        Next
    End If
End With

RaiseEvent Logging("Sending DATA command...")

SendMail = GetStatusCode(ExecuteCommand("DATA"), szLog)
    
RaiseEvent Logging(szLog)
    
If SendMail <> 354 Then szSMTPServerStatus = szLog: GoTo Quit
    
buff = Split(objMail.Make, vbCrLf)
ub = UBound(buff)

RaiseEvent Logging("Sending " & Str(ub + 1) & " lines of data...")

For l = 0 To ub
    If Len(buff(l)) Then
        If Asc(Mid$(buff(l), 1, 1)) = 46 Then buff(l) = "." & buff(l)
    End If
    buff(l) = buff(l) & vbCrLf
    Do While SMTP.CanSendData = False
        DoEvents
    Loop
    SMTP.WriteStringData buff(l), Len(buff(l)), 0
Next

RaiseEvent Logging("Sending End Of Data...")

SendMail = GetStatusCode(ExecuteCommand("."), szLog)

RaiseEvent Logging(szLog)

Quit:

RaiseEvent Logging("Sending QUIT command...")

GetStatusCode ExecuteCommand("QUIT"), szLog

RaiseEvent Logging(szLog)

RaiseEvent Logging("Server disconnected")

Set SMTP = Nothing
End Function

'==================================================
'propriétés
'==================================================

Public Property Let Secure(ByVal vData As Boolean)
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.Secure = True
    bSecure = vData
End Property
Public Property Get Secure() As Boolean
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.Secure
    Secure = bSecure
End Property

Public Property Let AUTH(ByVal vData As String)
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.AUTH = 5
    mvarAUTH = vData
End Property
Public Property Get AUTH() As String
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.AUTH
    AUTH = mvarAUTH
End Property

Public Property Let Password(ByVal vData As String)
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.Password = 5
    mvarPassword = vData
End Property

Public Property Get Password() As String
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.Password
    Password = mvarPassword
End Property

Public Property Let UserName(ByVal vData As String)
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.UserName = 5
    mvarUserName = vData
End Property

Public Property Get UserName() As String
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.UserName
    UserName = mvarUserName
End Property

Public Property Let domain(ByVal vData As String)
Attribute domain.VB_HelpID = 295
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.domain = 5
    mvardomain = vData
End Property
Public Property Get domain() As String
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.domain
    domain = mvardomain
End Property

Public Property Let SMTPPort(ByVal vData As Long)
Attribute SMTPPort.VB_HelpID = 293
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.SMTPPort = 5
    mvarSMTPPort = vData
End Property
Public Property Get SMTPPort() As Long
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.SMTPPort
    SMTPPort = mvarSMTPPort
End Property

Public Property Let SMTPServer(ByVal vData As String)
Attribute SMTPServer.VB_HelpID = 291
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.SMTPServer = 5
    mvarSMTPServer = vData
    mvardomain = Mid$(vData, InStr(vData, ".") + 1)
End Property
Public Property Get SMTPServer() As String
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.SMTPServer
    SMTPServer = mvarSMTPServer
End Property

'==================================================
'constructeur et destructeur
'==================================================

Private Sub Class_Initialize()
Set WS = New CWinsock
mvarSMTPPort = 25
End Sub

Private Sub Class_Terminate()
Set SMTP = Nothing
Set WS = Nothing
End Sub

