Private Sub cmdenviar_Click()
Dim sucesso As Boolean '
Dim mensagem As String
Dim mailer As SMTPsvg.mailer

Set mailer = CreateObject("SMTPsvg.Mailer") '- Conexão com a dll do servidor

mailer.RemoteHost = "mail.seuservidorsmtp.com.br" 'Local onde você colocará o smtp.

mailer.FromName = txtremetente '- Procura no form o nome colocado
mailer.FromAddress = txtemailremetente '- Procura no form o e-mail colocado
mailer.AddRecipient txtdestino, txtemaildestino '- O nome de quem está enviando e o E-mail
mailer.Subject = txtassunto '- Procura no form o assunto colocado

mailer.BodyText = txtTexto '- Procura no form o texto colocado

sucesso = mailer.SendMail

If sucesso Then
   mensagem = "O E-MAIL ENVIADO COM SUCESSO!"
Else
   mensagem = "O E-MAIL NÃO FOI ENVIADO COM SUCESSO!"
End If

MsgBox mensagem, vbInformation, "Enviando emails usando ASPMAIL"

End Sub

Private Sub Form_Load()
Dim strsql As String
Set ConClientes = New ADODB.Connection
Set rsClientes = New ADODB.Recordset

With ConClientes
  .Provider = "Microsoft.Jet.OLEDB.4.0"
  .ConnectionString = "Data Source=" & App.Path & "\Cadastro.mdb"
  .Open
End With

strsql = "SELECT Nome , Email FROM Clientes WHERE Sexo='F'"
rsClientes.Open strsql, ConClientes, adOpenForwardOnly, adLockReadOnly, adCmdText

End Sub

Private Sub Desconecta_BD()
  rsClientes.Close
  Set rsClientes = Nothing
  ConClientes.Close
  Set ConClientes = Nothing
End Sub

Private Sub Command1_Click()
Dim sucesso As Boolean
Dim total_emails As Integer

If rsClientes.recordcount > 0 Then

    While Not rsClientes

      Set EnviaEmail = CreateObject("SMTPsvg.Mailer")
      EnviaEmail.RemoteHost = "smtp.seuservidor.com.br"
      EnviaEmail.FromName = "Macoratti"
      EnviaEmail.FromAddress = "remetente@yahoo.com"
      EnviaEmail.AddRecipient rsClientes("nome"), rsClientes("email")
      EnviaEmail.Subject = "assunto"
      EnviaEmail.Bodytext = "Ola " & rsClientes("nome") & "," & Chr(13) & " seu texto"
      sucesso = EnviaEmail.SendMail

      rsClientes.movenext
      total_emails = total_emails + 1

    Wend
    MsgBox "Numero Total de Emails enviados : " & total_emails
Else
    MsgBox "Não há nenhum cliente para o critério informado !"
End If
Desconecta_BD

End Sub

1 control Winsock - chamado smtp

1 controle combobox

8 caixas de textos

3 frames

4 controles images

11 controles labels

Private Sub Form_Load()
Me.Height = 4125
Me.Width = 7440

cboservidorsmtp.AddItem "acad.bryant.edu"
cboservidorsmtp.AddItem "valley-internet.net"
cboservidorsmtp.AddItem "grove.ufl.edu"
cboservidorsmtp.AddItem "hacker.com"
cboservidorsmtp.AddItem "kroner.ucdavis.edu"
cboservidorsmtp.ListIndex = 0

End Sub

Private Sub Image1_Click()
  envia_email
End Sub

Private Sub envia_email()
  
  If txtdestinatario.Text = "" Then
      MsgBox "Informe o nome do destinario", vbCritical, "Enviando Email"
      txtdestinatario.SetFocus
      Exit Sub
  End If
  If txtremetente.Text = "" Then
      MsgBox "Informe o nome do remetente", vbCritical, "Enviando Email"
      txtremetente.SetFocus
      Exit Sub
  End If
  If InStr(1, txtemaildestinatario, "@") = 0 Then
      MsgBox "O email do destinatário deve conter um caracter @", vbCritical, "Enviando Email"
      txtemaildestinatario.SetFocus
      Exit Sub
  End If
  If InStr(1, txtemailremetente, "@") = 0 Then
      MsgBox "O email do remetente deve conter um caractere @", vbCritical, "Enviando Email"
      txtemailremetente.SetFocus
      Exit Sub
  End If
    
  lblstatus = "Conectando ..."
  smtp.Connect cboservidorsmtp.Text, Val(txtporta)

End Sub

Private Sub smtp_Connect()

verifica_status

If Not Val(temp(0)) = 220 Then
  MsgBox "Ocorreu o seguinte erro no servidor : " & vbCrLf + resposta
Conexao False
End If

lblstatus.Caption = "Recebendo mensagem..."

stmp.sendata "Ola " & smtp.LocalHostName & vbCrLf
DoEvents

verifica_status
recebe_dados

If Not Val(temp(0)) = 250 Then
  MsgBox "Ocorreu o seguinte erro no servidor : " & vbCrLf + resposta
  Conexao False
End If

'envia email
smtp.sendata "Email de :<" & txtremetente.Text & ">" & vbCrLf
DoEvents

verifica_status
recebe_dados

If Not Val(temp(0)) = 250 Then
  MsgBox "Ocorreu o seguinte erro no servidor : " & vbCrLf + resposta
  Conexao False
End If

smtp.SendData "Para : <" & txtdestinatario.Text & vbCrLf
DoEvents

verifica_status
recebe_dados

If Not Val(temp(0)) = 250 Then
  MsgBox "Ocorreu o seguinte erro no servidor : " & vbCrLf + resposta
  Conexao False
End If

smtp.SendData "Dados " & vbCrLf
DoEvents

verifica_status
recebe_dados

If Not Val(temp(0)) = 354 Then
  MsgBox "Ocorreu o seguinte erro no servidor : " & vbCrLf + resposta
  Conexao False
End If

lblstatus.Caption = "Enviando Email..."

smtp.SendData "De : <" & txtremetente.Text & ">" & vbCrLf & _
                      "Para : " & txtdestinatario.Text * vbCrLf & _
                      "Mailer: JcmSoft" & vbCrLf & _
                      "Mime-Version: 1.0" & vbCrLf & _
                      "Content-Type:text/html" & "charset=us-ascii" & vbCrLf & vbCrLf & txtassunto

smtp.SendData vbCrLf & "." & vbCrLf
DoEvents

verifica_status
recebe_dados

If Not Val(temp(0)) = 250 Then
  MsgBox "Ocorreu o seguinte erro no servidor : " & vbCrLf + resposta
  Conexao False
End If

smt.SendData "QUIT"
MsgBox "Mensagem enviada com sucesso ", vbInformation, "Envia E-mail"
End Sub

Private Sub smtp_DataArrival(ByVal bytesTotal As Long)
Dim Dados As String

 smtp.GetData Dados, vbString
 inDaDos = inDaDos & Dados
 If strcmp(Right$(inDaDos, 2), vbCrLf) = 0 Then inder = True

End Sub

Private Sub verifica_status()
'aguarda resposta
While Not inder
  If smtp.State = sckClosed Then Exit Sub
  DoEvents
Wend
End Sub

Private Sub recebe_dados()
  resposta = inDaDos
  inDaDos = ""
  inder = False
  temp = Split(resposta, " ")
End Sub

Private Sub cmdassunto_Click()
If cmdassunto.Caption = "&Assunto >>" Then
  Me.Height = 6285
  Me.Width = 7440
  cmdassunto.Caption = "&Assunto <<"
Else
  Me.Height = 4125
  Me.Width = 7440
  cmdassunto.Caption = "&Assunto >>"
End If
End Sub