Sample Code illustrating use of the Mabry SMTP Control and Looping through a DAO recordset

This code is attached to command button on a form. On the form are the fields txtProgress which displays various messages as well as lblStatus which displays a record count of the progress.

   On Local Error GoTo Some_Err
    
    Dim MyDB As Database, RS As Recordset
    Dim strBody As String, lngCount As Long, lngRSCount As Long
    
    DoCmd.RunCommand acCmdSaveRecord
    Set MyDB = DBEngine.Workspaces(0).Databases(0)
    
    Me!txtProgress = Null
    Mail1.Debug = 0
    Mail1.Action = MailActionNewMessage
    Mail1.Blocking = True
    Mail1.ConnectType = MailConnectTypeSMTP
    Mail1.Host = Me!goSMTPServer
    lblStatus.Caption = "Connecting..."
    Mail1.Action = MailActionConnect
    lblStatus.Caption = "Connected..."
    Mail1.Date = Format(Now(), "ddd, d mmm yyyy hh:mm:ss")
    Mail1.flags = MailSrcIsBody Or MailDstIsHost
    Mail1.EMailAddress = Me!goReplyToAddress
    Mail1.Subject = Me!epSubject
    Mail1.From = """" & Me!goRealName & """ <" & _
      Me!goReplyToAddress & ">"
    Mail1.Headers(Mail1.HeadersCount) = "X-Mailer: Mabry"
    lblStatus.Caption = "Writing Message "
    Mail1.Body(0) = Me!epText

   Set RS = MyDB.OpenRecordset _
      ("Email - Outstanding Promos")
    lngRSCount = RS.RecordCount
    If lngRSCount = 0 Then
      MsgBox "No promo email messages to send.", vbInformation
    Else
      RS.MoveLast
      RS.MoveFirst
      Do Until RS.EOF
        lngCount = lngCount + 1
        lblStatus.Caption = "Writing Message " & CStr(lngCount) _
          & " of " & CStr(lngRSCount) & "..."
        Mail1.To = RS!cEmailAddress
        Mail1.MessageID = Year(Now) & Month(Now) & Day(Now) & Fix(Timer) & "_MabryMail"
        Mail1.Action = MailActionWriteMessage
        RS.Edit
        RS("cpeDateTimeEmailed") = Now()
        RS.Update
        RS.MoveNext
      Loop
    
    End If
    RS.Close
    MyDB.Close
    Set RS = Nothing
    Set MyDB = Nothing
    Close
    
    Me!txtProgress = "Sent " & CStr(lngRSCount) & " emails."
    Mail1.Action = MailActionDisconnect
    lblStatus.Caption = "Email disconnected"
    MsgBox "Done sending Promo email. ", vbInformation, "Done"
    lblStatus.Caption = "Idle..."
    Exit Sub
    
Some_Err:
    'MousePointer = 0
    MsgBox "Error (" & CStr(Err.Number) & ") " & Err.Description, _
        vbExclamation, "Error!"
    Mail1.Action = MailActionDisconnect
    lblStatus.Caption = "Email disconnected"

[ Email FAQ ]