Solved

(100 pts) Checking for new Email - POP3

Posted on 2000-05-11
7
427 Views
Last Modified: 2012-05-04
I use Outlook 2000 which connects to an Exchange server that receives new Email.  Once Outlook detects that you have a new Email on the exchange server, it makes the default sound and puts a small envelope icon in the System Tray to let you know you have new Email on the server.  Outlook 95, 97, and 2000 all did this.

What I'd like to do is create a program that does this, but for POP3 Email accounts instead of exchange Email accounts.  I need sample code on how to check a POP3 Email account for new Email and if there is new mail, pop up a message box saying so.

Please provide sample code and explaination if needed.

Thanks,

HATCHET
0
Comment
Question by:HATCHET
7 Comments
 
LVL 1

Expert Comment

by:lochiano
ID: 2801170
Use a MAPIMessager controls and MSAgent.  This is basically a sample form that is in the VB6 section.  


''''frmMailMain'''''''''''
Option Explicit
Private bNewSession As Boolean ' Flag to signal logon status.
' Set the gbIgnoreEvent to True whenever you are
' about to do an operation that causes the DataGrid
' control's BeforeColEdit event to occur. When True,
' the event will exit without further execution.
Private gbIgnoreEvent As Boolean
Private WithEvents rsUnread As ADODB.Recordset
Private gbGridConfigured As Boolean ' Flag to configure DataGrid
Private gbRSalreadyPopulated As Boolean ' Flag to signal RS populated
Private blnGotOld As Boolean


Private Sub Form_Load()
    ' Configure StatusBar.

    sbrMapi.Panels(1).Key = "SessID"
    sbrMapi.Panels.Add , "MsgCnt" ' Add Panel
     
   
End Sub




Private Sub Form_Resize()
If Me.WindowState = 1 Then Exit Sub
If Me.Height > grdMess.Top + 1100 Then grdMess.Height = Me.Height - grdMess.Top - 1100
If Me.Width > 300 Then grdMess.Width = Me.Width - grdMess.Left - 200
End Sub

Private Sub Form_Unload(Cancel As Integer)
LogOff
End Sub

Private Sub tbrMail_ButtonClick(ByVal Button As MSComCtlLib.Button)
    ' Use Select Case statement to determine which button
    ' was clicked, then react appropriately.
    On Error GoTo ButtonErr
   
    Select Case Button.Key
    Case "LogOn"
    If HelpActive Then
        HelpUnpause
            Explain "You do not half to change you Email in order to use cheetah", Me.Left + tbrMail.Left, Me.Top + tbrMail.Top
            Explain "but if you wish to do so you can read your mail while you are in cheetah"
            Explain "This button is used to connect to your mail account and get the unread messages"
        HelpUnpause
    End If
   
   
    ' Log and fetch unread messages. CheckRS checks
    ' if the ADORecordset has already been populated,
    ' and populates it if needed. DoGrid configures the
    ' grid and populates with the recordset.
        If LogOn = True Then
            FetchUnreadOnly
            CheckRS
            DoGrid
        Else
            On Error GoTo 0
            Exit Sub
        End If
    Case "logOff" ' Log off
       
        If HelpActive Then
            HelpUnpause
                Explain "This ends the connection to Email. ", Me.Left, Me.Top
            HelpPause
            On Error GoTo 0
            Exit Sub
        End If
 
   
   
        LogOff
    Case "fetch"
        FetchUnreadOnly
           
        If HelpActive Then
            HelpUnpause
                Explain "This button looks again for any unread messages. ", Me.Left, Me.Top
            HelpPause
            On Error GoTo 0
            Exit Sub
        End If
 
        ' Check to see if the ADO Recordset is
        ' already populated. Then populate grid.
        CheckRS
        DoGrid
    Case "oldmail"
       
        If HelpActive Then
            HelpUnpause
                Explain "This button gets a list of all messages that you have read before. ", Me.Left, Me.Top
            HelpPause
            On Error GoTo 0
            Exit Sub
        End If
         
   
   
        FetchAll
        CheckRS
        DoGrid
       
    Case "compose" ' Create a new message.
               
        If HelpActive Then
            HelpUnpause
                Explain "This will send an Email message. ", Me.Left, Me.Top
            HelpPause
            On Error GoTo 0
            Exit Sub
        End If
 
   
        ComposeMessage
       
    Case "SummonWizard"
           If HelpActive Then
                BanishWizard
            Else
                SummonWizard frmShell, ""
            End If
            frmShell.mnuHelp(1).Checked = HelpActive
            frmShell.mnuHelp(1).Caption = IIf(HelpActive, "Banish Wizard", "Summon Help Wizard")

       
    Case "address"
        Debug.Print "something else"
    Case Else
        Debug.Print Button.Key
    End Select
    On Error GoTo 0
    Exit Sub
ButtonErr:
    Debug.Print Err.Number, Err.Description
    Resume Next
End Sub

Private Sub grdMess_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
Dim i As Integer
    If mapSess.SessionID = 0 Or mapMess.MsgCount = 0 Then Exit Sub
    If grdMess.RowContaining(Y) = -1 Then Exit Sub
    grdMess.Row = grdMess.RowContaining(Y)
    If gbIgnoreEvent Then Exit Sub
 
    On Error GoTo RowERR
    mapMess.MsgIndex = grdMess.Columns(0).value ' Set MsgIndex.
   
    Load frmMailRead ' Load the form.
    ' Read the message and headers and put it in
    ' the appropriate textboxes.
    With frmMailRead
        .lblFrom = mapMess.MsgOrigDisplayName
        .lblCC = GetList(mapCcList)
        .lblTo = GetList(mapToList)
        .lblSubject = mapMess.MsgSubject
        .txtRead = mapMess.MsgNoteText
       
                           
        For i = 0 To mapMess.AttachmentIndex
            .lstAttachment.AddItem mapMess.AttachmentName
        Next
       
       
    End With
    grdMess.Columns("Read").Text = "X"
   
    frmMailRead.Show vbModal
   
   
    On Error GoTo 0
    Exit Sub
RowERR:
    On Error GoTo 0
    Debug.Print Err.Number, Err.Description
    Resume Next


End Sub




Private Sub CheckRS()
    ' Check a flag, gbRSalreadyPopulated before
    ' continuing. Clear the recordset before
    ' populating it again.
    If gbRSalreadyPopulated Then
        ClearRS
        PopulateRS
    Else
        PopulateRS
        gbRSalreadyPopulated = True
    End If
End Sub

Private Sub DoGrid()
    ' Check a flag, gbGridConfigured, before
    ' continuing. If already configured, clear it.
    If gbGridConfigured Then
        gbIgnoreEvent = True
        grdMess.HoldFields ' Retain grid configuration.
        Set grdMess.DataSource = rsUnread
        gbIgnoreEvent = False
        grdMess.ReBind
    Else
        ConfigureGrid
    End If

End Sub

Public Sub ComposeMessage()
    On Error GoTo ComposeErr
    Dim strMessage As String
    ' Use the Compose method and then invoke the
    ' Send method. When the optional argument
    ' is set to True, the underlying mail system's
    ' form is used. Otherwise, you must create your
    ' own.

        mapMess.Compose
        mapMess.Send True

    Exit Sub
ComposeErr:
    Debug.Print Err.Number, Err.Description
    Resume Next
End Sub

Private Sub CreateRS()
    ' Create ADO recordset and add fields. Each field becomes a
    ' column in the DataGrid control.
   
    Set rsUnread = New ADODB.Recordset
    With rsUnread.Fields
        .Append "ID", adSmallInt
        .Append "Read", adBSTR
        .Append "Date Received", adDate
        .Append "From", adBSTR
        .Append "Subject", adBSTR
    End With
    rsUnread.Open
End Sub


Private Sub FetchUnreadOnly()
    With mapMess
         ' Fetch unread messages only, then display number
         ' of unread messages in Statusbar.
        .FetchUnreadOnly = True
        sbrMapi.Panels("MsgCnt").Text = "Reading"
        .Fetch
        sbrMapi.Panels("MsgCnt").Text = .MsgCount & " Messages"
    End With
End Sub




Private Sub FetchAll()
    With mapMess
         ' Fetch unread messages only, then display number
         ' of unread messages in Statusbar.
        .FetchUnreadOnly = False
        sbrMapi.Panels("MsgCnt").Text = "Reading"
        .Fetch
        sbrMapi.Panels("MsgCnt").Text = .MsgCount & " Messages"
        blnGotOld = (.MsgCount > 0)
    End With
End Sub


Private Sub ClearRS()
    ' Clear the recordset of all rows.
    If rsUnread.RecordCount = 0 Then Exit Sub
    Dim i As Integer
    gbIgnoreEvent = True
   
    rsUnread.MoveFirst
    If Not blnGotOld Then
        For i = 1 To rsUnread.RecordCount
            rsUnread.Delete adAffectCurrent
            DoEvents
        Next i
    End If
    gbIgnoreEvent = False

End Sub
Private Sub PopulateRS()
    gbIgnoreEvent = True ' Flag to prevent RowColChanged event from processing.
    Dim i As Integer
    For i = 0 To mapMess.MsgCount - 1
        mapMess.MsgIndex = i
        rsUnread.AddNew
        rsUnread!Id = i
        rsUnread![date received] = mapMess.MsgDateReceived
        rsUnread!From = mapMess.MsgOrigDisplayName
        rsUnread!subject = mapMess.MsgSubject
    Next i
    gbIgnoreEvent = False ' Reset flag.
   
End Sub
Private Sub ConfigureGrid()
    ' Set the width of the grid columns before
    ' setting the DataSource to the recordset.
   
    gbIgnoreEvent = True
    With grdMess
        Set .DataSource = rsUnread ' Fires event.
        .Columns("ID").Width = 0   ' Hide ID column.
        .Columns("Read").Width = 500
        .Columns("Date Received").Width = 900
        .Columns("From").Width = 2000
        .Columns("Subject").Width = 5000
    End With
    Dim fmtdate As StdDataFormat
   
    ' Use the Format object to format the
    ' date column.
    Set fmtdate = New StdDataFormat
    With fmtdate
        .Type = fmtCustom
        .Format = "Short Date"
     End With
    Set grdMess. _
    Columns("Date Received").DataFormat = fmtdate
   
    gbIgnoreEvent = False
    gbGridConfigured = True ' Set flag so we know
    ' we don't have to do this again.
End Sub


Private Function LogOn() As Boolean
    ' Create Recordset Object named rsUnread
    CreateRS

    ' If a session is already started,
    ' exit sub.
    If mapSess.NewSession Then
'        MsgBox "Session already established"
        LogOn = True
        Exit Function
    End If
   
    On Error GoTo errLogInFail
    With mapSess
       
        .DownLoadMail = True ' Set DownLoadMail to False to prevent immediate download or to TRUE to get new messages
        .LogonUI = True ' Use the underlying email system's logon UI.
        .SignOn ' Signon method.
        ' If successful, return True
        LogOn = True
        ' Set NewSession to True and set0
        ' variable flag to true
        .NewSession = True
        bNewSession = .NewSession
        mapMess.SessionID = .SessionID ' You must set this before continuing.
        sbrMapi.Panels("SessID") = "ID = " & .SessionID ' Just so you can see the SessionID.
    End With
    ' Enabled and disable buttons.
    ToggleButtonEnabled
    On Error GoTo 0
    Exit Function
   
errLogInFail:
    On Error GoTo 0
    Debug.Print Err.Number, Err.Description
    If Err.Number = 32003 Then
        MsgBox "Canceled Login"
        LogOn = False
    End If
    Exit Function
End Function
Public Sub LogOff()
    ' Logoff the MapSessions control.
    On Error Resume Next
    With mapSess
        .SignOff ' Close the session.
        .NewSession = False ' Flag for new session.
        bNewSession = .NewSession ' Reset flag.
    End With
'     If gblnInIDE Then Exit Sub
    ' Disable and enable buttons.
    ToggleButtonEnabled
   
    rsUnread.Close ' Close ADO recordset and set variable to Nothing.
    On Error GoTo 0
    Set rsUnread = Nothing
    gbRSalreadyPopulated = False
    gbGridConfigured = False
    Unload frmMailRead ' Unload the form.
    grdMess.ClearFields ' Clear the grid.
End Sub

Private Sub ToggleButtonEnabled()
    ' Toggle Enabled property of various buttons.
    With tbrMail
        .Buttons("LogOn").Enabled = Abs(.Buttons("LogOn").Enabled) - 1
        .Buttons("logOff").Enabled = Abs(.Buttons("logOff").Enabled) - 1
        .Buttons("fetch").Enabled = Abs(.Buttons("fetch").Enabled) - 1
        .Buttons("oldmail").Enabled = Abs(.Buttons("oldmail").Enabled) - 1
        .Buttons("compose").Enabled = Abs(.Buttons("compose").Enabled) - 1
        .Buttons("address").Enabled = Abs(.Buttons("address").Enabled) - 1
        .Buttons("address").ButtonMenus(1).Enabled = Abs(.Buttons("address").ButtonMenus(1).Enabled) - 1
        .Buttons("address").ButtonMenus(2).Enabled = Abs(.Buttons("address").ButtonMenus(2).Enabled) - 1
       
    End With
   
    ' Toggle menu enabled.
    mnuLogOn.Enabled = Abs(mnuLogOn.Enabled) - 1
    mnuLogOff.Enabled = Abs(mnuLogOff.Enabled) - 1
    mnuTools.Enabled = Abs(mnuTools.Enabled) - 1
    mnuCheck.Enabled = Abs(mnuCheck.Enabled) - 1
    mnuAddress.Enabled = Abs(mnuAddress.Enabled) - 1

End Sub

Private Function GetList(ListType As Integer) As String
    ' The function just gets all the recipients
    ' of a message and contatenates them.
    Dim i As Integer
    Dim strList As String
    For i = 0 To mapMess.RecipCount - 1
        mapMess.RecipIndex = i
        If mapMess.RecipType = ListType Then
            strList = strList & mapMess.RecipDisplayName & "; "
        End If
    Next i
    If strList = "" Then
        GetList = ""
        Exit Function
    End If
    ' Strip semicolon from last recipient name.
    GetList = Left(strList, Len(strList) - 2)

End Function


Private Sub mnuAddress_Click()
    ' Display the Addressbook.
    On Error GoTo AddressErr
    mapMess.Show True
    Exit Sub
AddressErr:
    Debug.Print Err.Number, Err.Description
    Resume Next
End Sub

Private Sub mnuCheck_Click()
    FetchUnreadOnly ' Fetch unread messages.
    CheckRS ' Check Recordset and fill.
    DoGrid ' Set Grid's DataSource to recordset.
   
End Sub

Private Sub mnuExit_Click()
    ' Sign off if not done yet, then unload form.
    If mapSess.SessionID <> 0 Then mapSess.SignOff
    Unload Me
End Sub

Private Sub mnuLogOff_Click()
    LogOff
End Sub

Public Sub mnuLogOn_Click()
    If LogOn = True Then
        FetchUnreadOnly
        CheckRS
        DoGrid
    Else
        Exit Sub
    End If
End Sub

Private Sub tbrMail_ButtonMenuClick(ByVal ButtonMenu As MSComCtlLib.ButtonMenu)
    On Error GoTo btnClickErr
    Select Case ButtonMenu.Key
    Case "global"
        mapMess.Show False
    Case "recepient"
        mapMess.Show True
    End Select
    On Error GoTo 0
    Exit Sub
btnClickErr:
    If Err.Number = mapUserAbort Then
        Resume Next
    Else
        MsgBox Err.Number & ": " & Err.Description
        On Error GoTo 0
    End If
   
End Sub



Public Sub SetWIW(DisplayHwnd As Long)
'NestSDI DisplayHwnd, hwnd
'Me.Show
'Me.Left = 10
'Me.Top = 10
MakeWiw DisplayHwnd, Me
End Sub



''''''''frmMailRead
Option Explicit
Private intMsgIndex As Integer


Private Sub Form_Load()
    ' Store this in case of errors.
    intMsgIndex = frmMailMain.mapMess.MsgIndex
End Sub

Private Sub Form_Resize()
If Me.WindowState = 1 Then Exit Sub
If Me.Width > 500 Then txtRead.Width = Me.Width - (txtRead.Left * 2)
lstAttachment.Left = txtRead.Left
lstAttachment.Width = txtRead.Width
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
OLE1.Delete
On Error GoTo 0
End Sub

Private Sub lstAttachment_Click()
Dim s As String
s = lstAttachment.Text
If DisplayCallError(CallNext(s)) = "" Then Exit Sub
OLE1.CreateLink s
OLE1.DoVerb (vbOLEOpen)
End Sub

Private Sub tbrRead_ButtonClick(ByVal Button As MSComCtlLib.Button)
    On Error GoTo SendErr
   
    Select Case Button.Key
    Case "reply"
        With frmMailMain.mapMess
            .Copy
            .Reply
            .AddressResolveUI = True
            .Send True
        End With

    Case "ReplyAll"
        With frmMailMain.mapMess
            .ReplyAll
            .Send True
        End With
    Case "forward"
        With frmMailMain.mapMess
            .Forward
            .AddressResolveUI = True
            .Send True
        End With
    Case Else
        Debug.Print Button.Key
    End Select
    On Error GoTo 0
    Exit Sub
SendErr:
    If Err.Number = mapInvalidComposeBufferAction Then
        frmMailMain.mapMess.MsgIndex = intMsgIndex ' Reset to read buffer.
        Resume
    Else 'other case
        MsgBox Err.Number & ": " & Err.Description
    End If
    On Error GoTo 0
End Sub
0
 

Accepted Solution

by:
BogdanGrama earned 100 total points
ID: 2802344
Try this my friend

Use winsock control


Private Enum POP3States
    POP3_Connect
    POP3_USER
    POP3_PASS
    POP3_STAT
    POP3_RETR
    POP3_DELE
    POP3_QUIT
End Enum
Private m_State         As POP3States
Private Sub Con()
    m_State = POP3_Connect
    Winsock1.Close
    Winsock1.LocalPort = 0
    Winsock1.Connect "mail.technapoli.it", 110
End Sub
Private Sub cmdDel_Click()
Unload Me
End Sub
Private Sub Command1_Click()
Form1.Show
End Sub
Private Sub Form_Activate()
Con
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim strData As String
    Static intMessages          As Integer 'the number of messages to be loaded
    Static intCurrentMessage    As Integer 'the counter of loaded messages
    Static strBuffer            As String  'the buffer of the loading message
    Winsock1.GetData strData
       Debug.Print strData
    If Left$(strData, 1) = "+" Or m_State = POP3_RETR Then
        Select Case m_State
            Case POP3_Connect
                intMessages = 0
                m_State = POP3_USER
                Winsock1.SendData "USER " & "finsiel" & vbCrLf
                Debug.Print "USER " & "finsiel"
            Case POP3_USER
                m_State = POP3_PASS
                Winsock1.SendData "PASS " & "finsiel2000" & vbCrLf
                Debug.Print "PASS " & "finsiel2000"
            Case POP3_PASS
                m_State = POP3_STAT
                Winsock1.SendData "STAT" & vbCrLf
                Debug.Print "STAT"
            Case POP3_STAT
                intMessages = CInt(Mid$(strData, 5, InStr(5, strData, " ") - 5))
                If intMessages > 0 Then
                    m_State = POP3_RETR
                    intCurrentMessage = intCurrentMessage + 1
                    Winsock1.SendData "RETR 1" & vbCrLf
                    Debug.Print "RETR 1"
                Else
                    m_State = POP3_QUIT
                    Winsock1.SendData "QUIT" & vbCrLf
                    Debug.Print "QUIT"
                    Winsock1.Close
                    Con
                End If
            Case POP3_RETR
                strBuffer = strBuffer & strData
                If InStr(1, strBuffer, vbLf & "." & vbCrLf) Then
                    strBuffer = Mid$(strBuffer, InStr(1, strBuffer, vbCrLf) + 2)
                    strBuffer = Left$(strBuffer, Len(strBuffer) - 3)
                    MsgBox strBuffer
                    strBuffer = ""
                     If intCurrentMessage = intCurrentMessage Then
                       m_State = POP3_QUIT
                      Winsock1.SendData "DELE 1" & vbCrLf
                      Winsock1.SendData "QUIT" & vbCrLf
                      Debug.Print "QUIT"
                    End If
                End If
            Case POP3_QUIT
                 Winsock1.Close
                 Con
                End Select
    Else
            Winsock1.Close
            Con
            MsgBox "POP3 Error: " & strData, _
            vbExclamation, "POP3 Error"
    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)
On Error Resume Next
'    MsgBox "Winsock Error: #" & Number & vbCrLf & _
'            Description
End Sub

Send me a note for more details


0
 

Expert Comment

by:Goshawk
ID: 2809776
0
What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
LVL 3

Author Comment

by:HATCHET
ID: 2814019
lochiano,

Overkill!  I don't want to debug the program you've posted, I just need sample code on how to check if I have new Email and if I do... tell me how many new ones I have.  Sorry.

Maybe if you could take out the parts of the code you posted that do just that, that would be cool, but... whoah... y'know?!

-----------------------------

BogdanGrama,

Your code works like a champ!  It actually goes out and checks Email, downloads the message and displays it just like regular Email program would!  Really kewl stuff.  However, it's doing more than I need.  I don't want a program that goes out and downloads the Email to display it, I just want to know if there is new Email, and if there is, how many new messages.

Can you send an alteration to your code that will do that?  Shouldn't be hard... you've got a working version posted here.

Thanks!

-----------------------------

Goshawk,

I went out and checked out that program... it's kewl and all... but I don't want someone else's program that does it, I want to know how to do it myself in VB.  I think I did see that they allowed you to download the source code, but I don't want to wade through their program to find the one small part that I need... the part that actually checks for new Emails.

If you'd get that from their source code and send it to me or post it, I'd up the points for your extra effort... but a simple link to their site doesn't answer this question.


Thanks to you all for helping me out here.  =]

HATCHET
0
 

Expert Comment

by:BogdanGrama
ID: 2816502
I send you a revision

Let's start from the top

put this in a form

4 textbox
1 listview
1 winsock control


Private Enum POP3States
    POP3_Connect
    POP3_USER
    POP3_PASS
    POP3_STAT
    POP3_RETR
    POP3_DELE
    POP3_QUIT
End Enum

Private m_State         As POP3States

Private m_oMessage      As CMessage
Private m_colMessages   As New CMessages
'

Private Sub cmdCheckMail_Click()
     
    'Check the emptiness of all the text fields except for the txtBody
    For Each c In Controls
        If TypeOf c Is TextBox And c.Name <> "txtBody" Then
            If Len(c.Text) = 0 Then
                MsgBox c.Name & " can't be empty", vbCritical
                Exit Sub
            End If
        End If
    Next
    '
    'Change the value of current session state
    m_State = POP3_Connect
    '
    'Close the socket in case it was opened while another session
    Winsock1.Close
    '
    'reset the value of the local port in order to let to the
    'Windows Sockets select the new one itself
    'It's necessary in order to prevent the "Address in use" error,
    'which can appear if the Winsock Control has already used while the  
    'previous session
    Winsock1.LocalPort = 0
    '
    'POP3 server waits for the connection request at the port 110.
    'According with that we want the Winsock Control to be connected to
    'the port number 110 of the server we have supplied in txtHost field
    Winsock1.Connect txtHost, 110

End Sub



Private Sub cmdDel_Click()
    Unload Me
End Sub

Private Sub lvMessages_ItemClick(ByVal Item As ComctlLib.ListItem)

    txtBody = m_colMessages(Item.Key).MessageBody
     
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

    Dim strData As String
     
    Static intMessages          As Integer 'the number of messages to be loaded
    Static intCurrentMessage    As Integer 'the counter of loaded messages
    Static strBuffer            As String  'the buffer of the loading message
    '
    'Save the received data into strData variable
    Winsock1.GetData strData
    Debug.Print strData
     
    If Left$(strData, 1) = "+" Or m_State = POP3_RETR Then
        'If the first character of the server's response is "+" then
        'server accepted the client's command and waits for the next one
        'If this symbol is "-" then here we can do nothing
        'and execution skips to the Else section of the code
        'The first symbol may differ from "+" or "-" if the received
        'data are the part of the message's body, i.e. when
        'm_State = POP3_RETR (the loading of the message state)
        Select Case m_State
            Case POP3_Connect
                '
                'Reset the number of messages
                intMessages = 0
                '
                'Change current state of session
                m_State = POP3_USER
                '
                'Send to the server the USER command with the parameter.
                'The parameter is the name of the mail box
                'Don't forget to add vbCrLf at the end of the each command!
                Winsock1.SendData "USER " & txtUserName & vbCrLf
                Debug.Print "USER " & txtUserName
                'Here is the end of Winsock1_DataArrival routine until the
                'next appearing of the DataArrival event. But next time this
                'section will be skipped and execution will start right after
                'the Case POP3_USER section.
            Case POP3_USER
                '
                'This part of the code runs in case of successful response to
                'the USER command.
                'Now we have to send to the server the user's password
                '
                'Change the state of the session
                m_State = POP3_PASS
                Winsock1.SendData "PASS " & txtPassword & vbCrLf
                Debug.Print "PASS " & txtPassword
            Case POP3_PASS
                '
                'The server answered positively to the process of the
                'identification and now we can send the STAT command. As a
                'response the server is going to return the number of
                'messages in the mail box and its size in octets
                '
                ' Change the state of the session
                m_State = POP3_STAT
                '
                'Send STAT command to know how many
                'messages in the mailbox
                Winsock1.SendData "STAT" & vbCrLf
                Debug.Print "STAT"
            Case POP3_STAT
                '
                'The server's response to the STAT command looks like this:
                '"+OK 0 0" (no messages at the mailbox) or "+OK 3 7564"
                '(there are messages). Evidently, the first of all we have to
                'find out the first numeric value that contains in the
                'server's response
                intMessages = CInt(Mid$(strData, 5, _
                              InStr(5, strData, " ") - 5))
                If intMessages > 0 Then
                    '
                    'Oops. There is something in the mailbox!
                    'Change the session state
                    m_State = POP3_RETR
                    '
                    'Increment the number of messages by one
                    intCurrentMessage = intCurrentMessage + 1
                    '
                    'and we're sending to the server the RETR command in
                    'order to retrieve the first message
                    Winsock1.SendData "RETR 1" & vbCrLf
                    Debug.Print "RETR 1"
                Else
                    'The mailbox is empty. Send the QUIT command to the
                    'server in order to close the session
                    m_State = POP3_QUIT
                    Winsock1.SendData "QUIT" & vbCrLf
                    Debug.Print "QUIT"
                    MsgBox "You have not mail.", vbInformation
                End If
            Case POP3_RETR
                'This code executes while the retrieving of the mail body
                'The size of the message could be quite big and the
                'DataArrival event may rise several time. All the received
                'data stores at the strBuffer variable:
                strBuffer = strBuffer & strData
                '
                'If case of presence of the point in the buffer it indicates
                'the end of the message (look at SMTP protocol)
                If InStr(1, strBuffer, vbLf & "." & vbCrLf) Then
                    '
                    'Done! The message has loaded
                    '
                    'Delete the first string-the server's response
                    strBuffer = Mid$(strBuffer, InStr(1, strBuffer, vbCrLf) + 2)
                    '
                    'Delete the last string. It contains only the "." symbol,
                    'which indicates the end of the message
                    strBuffer = Left$(strBuffer, Len(strBuffer) - 3)
                    '
                    'Add new message to m_colMessages collection
                    Set m_oMessage = New CMessage
                    m_oMessage.CreateFromText strBuffer
                    m_colMessages.Add m_oMessage, m_oMessage.MessageID
                    Set m_oMessage = Nothing
                    '
                    'Clear buffer for next message
                    strBuffer = ""
                    'Now we comparing the number of loaded messages with the
                    'one returned as a response to the STAT command
                    If intCurrentMessage = intMessages Then
                        'If these values are equal then all the messages
                        'have loaded. Now we can finish the session. Due to
                        'this reason we send the QUIT command to the server
                        m_State = POP3_QUIT
                        Winsock1.SendData "QUIT" & vbCrLf
                        Debug.Print "QUIT"
                    Else
                        'If these values aren't equal then there are
                        'remain messages. According with that
                        'we increment the messages' counter
                        intCurrentMessage = intCurrentMessage + 1
                        '
                        'Change current state of session
                        m_State = POP3_RETR
                        '
                        'Send RETR command to download next message
                        Winsock1.SendData "RETR " & _
                        CStr(intCurrentMessage) & vbCrLf
                        Debug.Print "RETR " & intCurrentMessage
                    End If
                End If
            Case POP3_QUIT
                'No matter what data we've received it's important
                'to close the connection with the mail server
                Winsock1.Close
                'Now we're calling the ListMessages routine in order to
                'fill out the ListView control with the messages we've          
                'downloaded
                Call ListMessages
        End Select
    Else
        'As you see, there is no sophisticated error
        'handling. We just close the socket and show the server's response
        'That's all. By the way even fully featured mail applications
        'do the same.
            Winsock1.Close
            MsgBox "POP3 Error: " & strData, _
            vbExclamation, "POP3 Error"
    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 & vbCrLf & _
            Description
             
End Sub

Private Sub ListMessages()

    Dim oMes As CMessage
    Dim lvItem As ListItem
     
    For Each oMes In m_colMessages
        Set lvItem = lvMessages.ListItems.Add
        lvItem.Key = oMes.MessageID
        lvItem.Text = oMes.From
        lvItem.SubItems(1) = oMes.Subject
        lvItem.SubItems(2) = oMes.SendDate
        lvItem.SubItems(3) = oMes.Size
    Next
     
End Sub

I have for you 2 classes to manage
the listview

cmessage.cls

'local variables to hold property values
Private m_strReturnPath      As String
Private m_strReceived        As String
Private m_strSendDate        As String
Private m_strMessageID       As String
Private m_strMessageTo       As String
Private m_strFrom            As String
Private m_strSubject         As String
Private m_strReplyTo         As String
Private m_strSender          As String
Private m_strCC              As String
Private m_strBCC             As String
Private m_strInReplyTo       As String
Private m_strReferences      As String
Private m_strKeywords        As String
Private m_strComments        As String
Private m_strEncrypted       As String
Private m_strMessageText     As String
Private m_strMessageBody     As String
Private m_strHeaders         As String
Private m_lSize              As Long

Public Sub CreateFromText(strMessage As String)

    Dim intPosA         As Integer
    Dim vHeaders        As Variant
    Dim vField          As Variant
    Dim strHeader       As String
    Dim strHeaderName   As String
    Dim strHeaderValue  As String
     
    intPosA = InStr(1, strMessage, vbCrLf & vbCrLf)
    If intPosA Then
        m_strHeaders = Left$(strMessage, intPosA - 1)
        m_strMessageBody = Right$(strMessage, Len(strMessage) - intPosA - 3)
        m_strMessageText = strMessage
    Else
        Err.Raise vbObjectError + 512 + 101, "CMessage.CreateFromText", _
                    "Invalid message format"
        Exit Sub
    End If
     
    vHeaders = Split(m_strHeaders, vbCrLf)
    For Each vField In vHeaders
        strHeader = CStr(vField)
        intPosA = InStr(1, strHeader, ":")
        If intPosA Then
            strHeaderName = LCase(Left$(strHeader, intPosA - 1))
        Else
            strHeaderName = ""
        End If
        strHeaderValue = Trim$(Right$(strHeader, Len(strHeader) - intPosA))
        Select Case strHeaderName
            Case "return-path"
                m_strReturnPath = strHeaderValue
            Case "received"
                m_strReceived = strHeaderValue
            Case "from"
                m_strFrom = strHeaderValue
            Case "sender"
                m_strSender = strHeaderValue
            Case "reply-to"
                m_strReplyTo = strHeaderValue
            Case "to"
                m_strMessageTo = strHeaderValue
            Case "cc"
                m_strCC = strHeaderValue
            Case "bcc"
                m_strBCC = strHeaderValue
            Case "message-id"
                m_strMessageID = strHeaderValue
            Case "in-reply-to"
                m_strInReplyTo = strHeaderValue
            Case "references"
                m_strReferences = strHeaderValue
            Case "keywords"
                m_strKeywords = strHeaderValue
            Case "subject"
                m_strSubject = strHeaderValue
            Case "comments"
                m_strComments = strHeaderValue
            Case "encrypted"
                m_strEncrypted = strHeaderValue
            Case "date"
                m_strSendDate = strHeaderValue
        End Select
    Next
     
End Sub


Public Function CombineMessage() As String

End Function


Public Property Let Headers(ByVal vData As String)
    m_strHeaders = vData
End Property


Public Property Get Headers() As String
    Headers = m_strHeaders
End Property

Public Property Let MessageBody(ByVal vData As String)
    m_strMessageBody = vData
End Property

Public Property Get MessageBody() As String
    MessageBody = m_strMessageBody
End Property

Public Property Let MessageText(ByVal vData As String)
    m_strMessageText = vData
End Property

Public Property Get MessageText() As String
    MessageText = m_strMessageText
End Property

Public Property Let Encrypted(ByVal vData As String)
    m_strEncrypted = vData
End Property

Public Property Get Encrypted() As String
    Encrypted = m_strEncrypted
End Property

Public Property Let Comments(ByVal vData As String)
    m_strComments = vData
End Property

Public Property Get Comments() As String
    Comments = m_strComments
End Property

Public Property Let Keywords(ByVal vData As String)
    m_strKeywords = vData
End Property

Public Property Get Keywords() As String
    Keywords = m_strKeywords
End Property

Public Property Let References(ByVal vData As String)
    m_strReferences = vData
End Property

Public Property Get References() As String
    References = m_strReferences
End Property

Public Property Let InReplyTo(ByVal vData As String)
    m_strInReplyTo = vData
End Property

Public Property Get InReplyTo() As String
    InReplyTo = m_strInReplyTo
End Property

Public Property Let BCC(ByVal vData As String)
    m_strBCC = vData
End Property

Public Property Get BCC() As String
    BCC = m_strBCC
End Property

Public Property Let CC(ByVal vData As String)
    m_strCC = vData
End Property

Public Property Get CC() As String
    CC = m_strCC
End Property

Public Property Let Sender(ByVal vData As String)
    m_strSender = vData
End Property

Public Property Get Sender() As String
    Sender = m_strSender
End Property

Public Property Let ReplyTo(ByVal vData As String)
    m_strReplyTo = vData
End Property

Public Property Get ReplyTo() As String
    ReplyTo = m_strReplyTo
End Property

Public Property Let Subject(ByVal vData As String)
    m_strSubject = vData
End Property

Public Property Get Subject() As String
    Subject = m_strSubject
End Property

Public Property Let From(ByVal vData As String)
    m_strFrom = vData
End Property

Public Property Get From() As String
    From = m_strFrom
End Property

Public Property Let MessageTo(ByVal vData As String)
    m_strMessageTo = vData
End Property

Public Property Get MessageTo() As String
    MessageTo = m_strMessageTo
End Property

Public Property Let MessageID(ByVal vData As String)
    m_strMessageID = vData
End Property

Public Property Get MessageID() As String
    MessageID = m_strMessageID
End Property

Public Property Let SendDate(ByVal vData As String)
    m_strSendDate = vData
End Property

Public Property Get SendDate() As String
    SendDate = m_strSendDate
End Property

Public Property Let Received(ByVal vData As String)
    m_strReceived = vData
End Property

Public Property Get Received() As String
    Received = m_strReceived
End Property

Public Property Let ReturnPath(ByVal vData As String)
    m_strReturnPath = vData
End Property

Public Property Get ReturnPath() As String
    ReturnPath = m_strReturnPath
End Property

Public Property Get Size() As Long
    Size = Len(m_strMessageText)
End Property

and cmessages.cls

'local variable to hold collection
Private mCol As Collection

Public Sub Add(oMessage As CMessage, Optional sKey As String)
     
    If Len(sKey) = 0 Then
        mCol.Add oMessage
    Else
        mCol.Add oMessage, sKey
    End If

End Sub

Public Property Get Item(vntIndexKey As Variant) As CMessage
  Set Item = mCol(vntIndexKey)
End Property

Public Property Get Count() As Long
    Count = mCol.Count
End Property

Public Sub Remove(vntIndexKey As Variant)
    mCol.Remove vntIndexKey
End Sub

Public Property Get NewEnum() As IUnknown
    Set NewEnum = mCol.[_NewEnum]
End Property

Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub

Private Sub Class_Terminate()
    Set mCol = Nothing
End Sub

Try now

For Mail send

The code is actually pretty simple, it simply uses windows own Winsock to send e-mail via
SMTP. It makes a connection via TCP on port 25 (If you don't understand what TCP and port
25 is, you may consider brushing up on TCP/IP before using this, but it is not a requirement)
and sends basically text to the SMTP mail server. This is what SMTP stands for SIMPLE Mail
Transport Protocol.  I have tried as much as possible to self document the code, so I will
not got into details here. Just look through it and see what you can do.


7 textbox
-from(email adress)-your name
-to                -there name
-subject           -mail server

-body
 
1 winsock control
1 status bar
2 command buttons










Dim Response As String, Reply As Integer, DateNow As String
Dim first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String
Dim Start As Single, Tmr As Single



Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)
           
    Winsock1.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail pre program start
     
If Winsock1.State = sckClosed Then ' Check to see if socet is closed
    DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
    first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf ' Get who's sending E-Mail address
    Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf ' Get who mail is going to
    Third = "Date:" + Chr(32) + DateNow + vbCrLf ' Date when being sent
    Fourth = "From:" + Chr(32) + FromName + vbCrLf ' Who's Sending
    Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf ' Who it going to
    Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf ' Subject of E-Mail
    Seventh = EmailBodyOfMessage + vbCrLf ' E-mail message body
    Ninth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf ' What program sent the e-mail, customize this
    Eighth = Fourth + Third + Ninth + Fifth + Sixth  ' Combine for proper SMTP sending

    Winsock1.Protocol = sckTCPProtocol ' Set protocol for sending
    Winsock1.RemoteHost = MailServerName ' Set the server address
    Winsock1.RemotePort = 25 ' Set the SMTP Port
    Winsock1.Connect ' Start connection
     
    WaitFor ("220")
     
    StatusTxt.Caption = "Connecting...."
    StatusTxt.Refresh
     
    Winsock1.SendData ("HELO worldcomputers.com" + vbCrLf)

    WaitFor ("250")

    StatusTxt.Caption = "Connected"
    StatusTxt.Refresh

    Winsock1.SendData (first)

    StatusTxt.Caption = "Sending Message"
    StatusTxt.Refresh

    WaitFor ("250")

    Winsock1.SendData (Second)

    WaitFor ("250")

    Winsock1.SendData ("data" + vbCrLf)
     
    WaitFor ("354")


    Winsock1.SendData (Eighth + vbCrLf)
    Winsock1.SendData (Seventh + vbCrLf)
    Winsock1.SendData ("." + vbCrLf)

    WaitFor ("250")

    Winsock1.SendData ("quit" + vbCrLf)
     
    StatusTxt.Caption = "Disconnecting"
    StatusTxt.Refresh

    WaitFor ("221")

    Winsock1.Close
Else
    MsgBox (Str(Winsock1.State))
End If
   
End Sub
Sub WaitFor(ResponseCode As String)
    Start = Timer ' Time event so won't get stuck in loop
    While Len(Response) = 0
        Tmr = Start - Timer
        DoEvents ' Let System keep checking for incoming response **IMPORTANT**
        If Tmr > 50 Then ' Time in seconds to wait
            MsgBox "SMTP service error, timed out while waiting for response", 64, MsgTitle
            Exit Sub
        End If
    Wend
    While Left(Response, 3) <> ResponseCode
        DoEvents
        If Tmr > 50 Then
            MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64, MsgTitle
            Exit Sub
        End If
    Wend
Response = "" ' Sent response code to blank **IMPORTANT**
End Sub


Private Sub Command1_Click()
    SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text
    'MsgBox ("Mail Sent")
    StatusTxt.Caption = "Mail Sent"
    StatusTxt.Refresh
    Beep
     
    Close
End Sub

Private Sub Command2_Click()
     
    End
     
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

    Winsock1.GetData Response ' Check for incoming response *IMPORTANT*

End Sub

Try


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


What about now?

Send me a note

Bogdan




0
 

Expert Comment

by:BogdanGrama
ID: 2816517
just for new mail

in state section put a msg box to dysplay the number of e-mails.



Delete the retry section if you whant.
0
 
LVL 3

Author Comment

by:HATCHET
ID: 2819116
BogdanGrama,

Thanks for all the work you've done on this!  

HATCHET
0

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
Article by: Martin
Here are a few simple, working, games that you can use as-is or as the basis for your own games. Tic-Tac-Toe This is one of the simplest of all games.   The game allows for a choice of who goes first and keeps track of the number of wins for…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

757 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now