VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CPOP3"
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_SUCH_USER As Long = 1317&
Private Const ERROR_LOGON_FAILURE As Long = 1326&
Private Const ERROR_SERVER_DISABLED As Long = 1341&
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

Dim WS As CWinsock
Dim POP3 As CSocket

'variables locales de stockage des valeurs de propriétés
Private mvarPOP3Server As String 'copie locale
Private mvarPOP3Port As Long 'copie locale
Private mvarUserName As String 'copie locale
Private mvarPassword As String 'copie locale
Private bSecure As Boolean

Public Event Logging(ByVal szText As String)
Public Event Receive(ByVal szText As String, ByVal cbReceivedSize As Long, ByVal cbMailSize As Long, ByVal lParam As Long)

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

Private Function WaitResult(Optional bMultiLine As Boolean = False) 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 = 256
    buff = Space(256)
    lcb = 0
    ret = POP3.ReadStringData(buff, cb, lcb)
    DoEvents
    If lcb Then
        buff = Mid$(buff, 1, lcb)
        WaitResult = WaitResult & buff
        
        If bMultiLine = False Then
            bLastLine = (Mid$(buff, lcb - 1, 2) = vbCrLf)
        Else
            bLastLine = (InStr(WaitResult, vbCrLf & "." & vbCrLf) > 0)
        End If
    End If
Loop Until bLastLine
End Function

Private Function ExecuteCommand(szCommand As String, Optional bMultiLine As Boolean = False) As String
Dim lw As Long

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

ExecuteCommand = WaitResult(bMultiLine)
End Function

Private Function GetStatus(szReply As String, Optional szLog As String) As Boolean
    On Local Error Resume Next
    Dim pos1 As Long, pos2 As Long
    
    GetStatus = (Mid$(szReply, 1, 3) = "+OK")
    If Not IsMissing(szLog) Then
        pos1 = InStr(szReply, " ")
        pos2 = InStr(pos1 + 1, szReply, vbCrLf)
        If pos2 = 0 Then pos2 = Len(szReply) + 1
        szLog = Trim$(Mid$(szReply, pos1 + 1, pos2 - pos1 - 1))
    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 Connect() As Long
    Dim res As Boolean, szLog As String
    
    Set POP3 = WS.CreateTCPSocket
    
    RaiseEvent Logging("Connecting to server " & mvarPOP3Server & " on port " & mvarPOP3Port & "...")
    Connect = POP3.connectbyname(mvarPOP3Server, mvarPOP3Port)
    
    If Connect <> 0 Then
        RaiseEvent Logging("Connection Failed.")
        Exit Function
    End If
    
    If bSecure Then
        POP3.BeginSecure "mycert.pem", "", "root.pem", vbNullString
    End If
    
    RaiseEvent Logging("Successfully connected. Wait greetings...")
    res = GetStatus(WaitResult(False), szLog)
    RaiseEvent Logging(szLog)
    
    If res = False Then Connect = ERROR_SERVER_DISABLED: Set POP3 = Nothing: Exit Function
    
    RaiseEvent Logging("Sending Username...")
    res = GetStatus(ExecuteCommand("USER " & mvarUserName, False), szLog)
    RaiseEvent Logging(szLog)
    
    If res = False Then Connect = ERROR_NO_SUCH_USER: GoTo Quit
    
    RaiseEvent Logging("Sending Password...")
    res = GetStatus(ExecuteCommand("PASS " & mvarPassword, False), szLog)
    RaiseEvent Logging(szLog)
    
    If res = False Then Connect = ERROR_LOGON_FAILURE: GoTo Quit
    
    Exit Function
Quit:
    POP3.WriteStringData "QUIT" & vbCrLf, 6, 0
    Set POP3 = Nothing
End Function

Public Function GetNumberOfUnreadMail(Optional lpcbUnreadMailsSize As Long) As Long
Dim szResult As String, szLog As String

RaiseEvent Logging("Sending STAT command...")
szResult = ExecuteCommand("STAT", False)
If GetStatus(szResult, szLog) = False Then
    GetNumberOfUnreadMail = -1
    If Not IsMissing(lpcbUnreadMailsSize) Then lpcbUnreadMailsSize = -1
Else
    GetNumberOfUnreadMail = CLng(Val(Mid$(szResult, 5, InStr(5, szResult, " ", vbBinaryCompare) - 5)))
    If Not IsMissing(lpcbUnreadMailsSize) Then lpcbUnreadMailsSize = CLng(Val(Mid$(szResult, InStr(5, szResult, " ", vbBinaryCompare) - 5)))
End If
RaiseEvent Logging(szLog)
End Function

Public Function GetMessageSize(ByVal dwMessageNumber As Long) As Long
Dim szResult As String, szLog As String

RaiseEvent Logging("Sending LIST command for message " & dwMessageNumber & "...")
szResult = ExecuteCommand("LIST " & dwMessageNumber, False)
If GetStatus(szResult, szLog) = False Then
    GetMessageSize = -1
Else
    GetMessageSize = CLng(Val(Mid$(szResult, InStr(5, szResult, " ", vbBinaryCompare) + 1)))
End If
RaiseEvent Logging(szLog)
End Function

Public Function GetMessageUIDL(ByVal dwMessageNumber As Long) As String
Dim szResult As String, szLog As String, pos As Long

RaiseEvent Logging("Sending UIDL command for message " & dwMessageNumber & "...")
szResult = ExecuteCommand("UIDL " & dwMessageNumber, False)
If GetStatus(szResult, szLog) = False Then
    GetMessageUIDL = vbNullString
Else
    pos = InStr(5, szResult, " ", vbBinaryCompare) + 1
    GetMessageUIDL = Mid$(szResult, pos, Len(szResult) - pos - 1)
End If
RaiseEvent Logging(szLog)
End Function

Public Function GetMIMEHeader(ByVal dwMessageNumber As Long) As CMIMEHeader
Dim szResult As String, res As Boolean, pos As Long, szLog As String

RaiseEvent Logging("Sending TOP command for message " & dwMessageNumber & "...")
szResult = ExecuteCommand("TOP " & dwMessageNumber & " 0", True)
res = GetStatus(szResult, szLog)
RaiseEvent Logging(szLog)

If res Then
    pos = InStr(szResult, vbCrLf) + 1
    Set GetMIMEHeader = New CMIMEHeader
    GetMIMEHeader.Parse Mid$(szResult, pos, Len(szResult) - 5 - pos)
End If
End Function

Public Function GetMailHeader(ByVal dwMessageNumber As Long) As CMailHeader
Dim szResult As String, res As Boolean, pos As Long, szLog As String

RaiseEvent Logging("Sending TOP command for message " & dwMessageNumber & "...")
szResult = ExecuteCommand("TOP " & dwMessageNumber & " 0", True)
res = GetStatus(szResult, szLog)
RaiseEvent Logging(szLog)

If res Then
    pos = InStr(szResult, vbCrLf) + 1
    Set GetMailHeader = New CMailHeader
    GetMailHeader.Parse Mid$(szResult, pos, Len(szResult) - 5 - pos)
End If
End Function

Public Function GetMailHeaders(ByVal dwMessageNumber As Long, lpMessageHeader As CMailHeader, lpMIMEHeader As CMIMEHeader) As Boolean
Dim szResult As String, pos As Long, szLog As String

RaiseEvent Logging("Sending TOP command for message " & dwMessageNumber & "...")
szResult = ExecuteCommand("TOP " & dwMessageNumber & " 0", True)
GetMailHeaders = GetStatus(szResult, szLog)
RaiseEvent Logging(szLog)

If GetMailHeaders Then
    pos = InStr(szResult, vbCrLf) + 1
    szResult = Mid$(szResult, pos, Len(szResult) - 5 - pos)
    
    Set lpMessageHeader = New CMailHeader
    lpMessageHeader.Parse szResult

    Set lpMIMEHeader = New CMIMEHeader
    lpMIMEHeader.Parse szResult
End If
End Function

Public Function RetrieveMessageAsync(ByVal dwMessageNumber As Long, Optional ByVal lParam As Long = 0) As Boolean
Dim buff As String, lastbuff As String, cb As Long, lcb As Long, msize As Long, lprog As Long
Dim ret As Long, bLastLine As Boolean, pos As Long, szLog As String, poslast As Long
Dim lw As Long, szCommand As String, szResult As String, c As String

RaiseEvent Logging("Prepare retrieving...")
msize = GetMessageSize(dwMessageNumber)
If msize = -1 Then Exit Function

RaiseEvent Logging("Sending RETR command for message " & dwMessageNumber & "...")

szCommand = "RETR " & dwMessageNumber
If POP3.WriteStringData(szCommand & vbCrLf, Len(szCommand) + 2, lw) <> 0 Then Exit Function

Do
    c = vbNullChar
    If POP3.ReadStringData(c, 1, lw) = 0 Then szResult = szResult & c
Loop Until c = vbLf

RetrieveMessageAsync = GetStatus(szResult, szLog)
RaiseEvent Logging(szLog)
If RetrieveMessageAsync = False Then Exit Function

RetrieveMessageAsync = True

bLastLine = False
Do
    cb = 256
    buff = Space(256)
    lcb = 0
    ret = POP3.ReadStringData(buff, cb, lcb)
    DoEvents
    If lcb Then
        buff = lastbuff & Mid$(buff, 1, lcb)
        lcb = lcb + Len(lastbuff)
        bLastLine = (InStr(buff, vbCrLf & "." & vbCrLf) > 0)
        
        If bLastLine Then
            lprog = msize
            buff = Mid$(buff, 1, lcb - 3)
        Else
            poslast = InStrRev(buff, vbCrLf)
            If poslast Then
                lcb = poslast - 1
                lastbuff = Mid$(buff, poslast)
                buff = Replace(Mid$(buff, 1, lcb), vbCrLf & ".", vbCrLf)
                
            Else
                lastbuff = vbNullString
            End If
            'If Asc(Mid$(buff, 1, 1)) = 46 Then
            '    buff = Mid$(buff, 2)
            'End If
            
            lprog = lprog + lcb
        End If
        
        RaiseEvent Receive(buff, lprog, msize, lParam)
    End If
Loop Until bLastLine
RaiseEvent Logging("Successfully retrieving " & msize & " bytes for message " & dwMessageNumber)
End Function

Public Function MarkMessageForDeletion(ByVal dwMessageNumber As Long) As Boolean
Dim szLog As String

RaiseEvent Logging("Sending DELE command for message " & dwMessageNumber & "...")
MarkMessageForDeletion = GetStatus(ExecuteCommand("DELE " & dwMessageNumber, False))
RaiseEvent Logging(szLog)
End Function

Public Function UnmarkAllMessages() As Boolean
Dim szLog As String

RaiseEvent Logging("Sending RSET command...")
UnmarkAllMessages = GetStatus(ExecuteCommand("RSET", False))
RaiseEvent Logging(szLog)
End Function

Public Function Disconnect() As Boolean
    Dim szLog As String
    
    RaiseEvent Logging("Sending QUIT command...")
    Disconnect = GetStatus(ExecuteCommand("QUIT"))
    RaiseEvent Logging(szLog)
    
    POP3.EndSecure
    
    Set POP3 = New CSocket
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 POP3Port(ByVal vData As Long)
Attribute POP3Port.VB_HelpID = 311
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.POP3Port = 5
    mvarPOP3Port = vData
End Property

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

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

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

Public Property Let Password(ByVal vData As String)
Attribute Password.VB_HelpID = 307
'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)
Attribute UserName.VB_HelpID = 305
'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

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

Private Sub Class_Initialize()
    Set WS = New CWinsock
    mvarPOP3Port = 110
End Sub

Private Sub Class_Terminate()
    Set WS = Nothing
End Sub
