Bulk Email Via Vb

[Brown]

I am currently desgning a system for company who wishes to be able to interrogate there client database, and send emails to all there clients filtered on a given critieria. The problem I am having is that I can create the emails ready to go in the outbox but can't get the computer to send the emails and connect to the internet.

Any help or soloutions grealy apreciated

Jamie Brown

This is a simple example how to send mail to your mail server (smtp).

Make a new form called "frmmain" and place some controls on it.

Textboxes:
txtFromEmailAddress = From E-Mail addres
txtFromName = From name
txtToEmailAddress = To E-Mail addres
ToNametxt = To name
txtEmailSubject = Subject
txtEmailServer = SMTP server
txtEmailBodyOfMessage = E-Mail message

Labels:
StatusTxt = Sending status

and twoo buttons "Command1" and "Command2"
Command1 = "Sendmail"
Command2 = "Exit"

This example is using a Winsock control.

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

Goodluck...

[HeSaidJoe]

'If your client has outlook you can do it this way.
'you can set your sql to return only those you want to include

Option Explicit

Private Sub Form_Load()
    Dim Dbs As Database, Rst As Recordset
    Dim objOutlook As New Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookAttach As Object
    Dim mySubject As String
    Dim strAttachments As String
    
    'your attachment
    strAttachments = "C:\Books\trythis.txt"
    
    'set my subject line on condition
    If Format(Now, "DD") >= 12 And Format(Now, "DD") <= 31 Then
      mySubject = "Mid Month Data for " & Format(Now, "mmmm yyyy")
    Else
     mySubject = "Month End Data for " & Format(Now, "mmmm yyyy")
    End If
    
    ' Open Database and goto first record
    Set Dbs = OpenDatabase(App.Path & "\Contacts.mdb")
    Set Rst = Dbs.OpenRecordset("Contacts")
    Rst.MoveFirst
    
    ' Go through each record
    Do Until Rst.EOF
    ' Create new message
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    
    'fill in subject/body/etc for each person in mdb
    With objOutlookMsg
    .To = Rst!email
    .Subject = mySubject
    .Body = "To All Parties Concerned:" & vbNewLine & vbNewLine
    .Body = myBodyString 'or read a file or a field from a database
    .Importance = olImportanceHigh
    Set objOutlookAttach = .Attachments.Add(strAttachments)
    .ReadReceiptRequested = True
    .Send
    End With
    'get rid of old message
    Set objOutlookMsg = Nothing
    
    'move to next record
    Rst.MoveNext
    Loop
    
    ' Close Outlook instance: Important!
    Set objOutlook = Nothing
    
    ' Close database
    Dbs.Close
    
    'message user that job is complete
    MsgBox "Auto Email Complete", vbInformation
    
    Set Dbs = Nothing
    Set Rst = Nothing
End Sub

[hmcheung]

hey HeSaidJoe,

Your code is cool~~ I've tried it and it woks. thanks.
How about altering the sender information? I'd like to set the sender to another email address which is different to that I'm using to send the bulk emails. I think I can change it in the Account Settings in Outlook, but I want to let the user key in the sender's email at runtime. Any ideas? thanks!