Simple VB emailer

[moeur]

Here is a class you can use to send email from VB. I wrote it years ago, but have seen a few requests for info on emailing.
Here is an example of how to use the class

Edit: Before using the class you'll have to add a refernce to MSWINSCK.OCX
Goto Project\References Browse to system32\MSWINSOCK.OCX

Option Explicit
 
Private WithEvents SMTP As clsSMTP
 
Private Sub Command1_Click()
 
With SMTP
 'who is the email from?
 .Sender = "YoMama"
 'who is it going to?
 .Recipient = "[email protected]"
 'your SMTP server
 .SMTPhost = "smtp.myserver.com"
 'optional subject line
 .Subject = "SMTP test"
 'make connection to the server
 .OpenMail
 'did connection succeed?
 If Not .Connected Then Exit Sub
 'you can send as many lines as you want here
 .Send "Bill,"
 .Send "This is a test of your wonderful SMTP client!"
 'make sure you close or nothing will get sent
 .CloseMail
End With
 
End Sub
 
Private Sub Form_Load()
    Set SMTP = New clsSMTP
End Sub
 
 
Private Sub SMTP_Error(Code As Integer, Message As String)
    Debug.Print "SMTP Error "; Code, Message
End Sub
 
Private Sub SMTP_ServerResponse(Reply As Integer, Message As String)
    Debug.Print Reply, Message
End Sub

Pretty simple, Now here is the class

Option Explicit
 
Private mvarConnected As Boolean
Private mvarRecipient As String
Private mvarSender As String
Private mvarSMTPhost As String
Private mvarSubject As String
 
Private WithEvents Winsock As MSWinsockLib.Winsock
 
Const OK = 250
Const Connection = 220
Const ReadyforData = 354
Const UserUnknown = 550
 
Dim Reply As Integer
Dim Message As String
Dim MyName As String
Dim ErrMSg As String
 
Event Error(Code As Integer, Message As String)
Event ServerResponse(Reply As Integer, Message As String)
 
Private Function WaitFor(R As Integer) As Boolean
Dim A
    A = Timer + 3
    While Not Reply = R And A > Timer
    DoEvents
    Wend
    If A < Timer Then
        WaitFor = True
    Else
        WaitFor = False
    End If
    Reply = 0
End Function
 
Public Property Let Subject(ByVal vData As String)
    mvarSubject = vData
End Property
 
Public Property Get Subject() As String
    Subject = mvarSubject
End Property
 
Public Property Let SMTPhost(ByVal vData As String)
    mvarSMTPhost = vData
End Property
 
Public Property Get SMTPhost() As String
    SMTPhost = mvarSMTPhost
End Property
 
Public Sub Send(Message As String)
 Winsock.SendData Message & vbCrLf
End Sub
 
Public Property Let Sender(ByVal vData As String)
    mvarSender = vData
End Property
 
Public Property Get Sender() As String
    Sender = mvarSender
End Property
 
Public Property Let Recipient(ByVal vData As String)
    mvarRecipient = vData
End Property
 
Public Property Get Recipient() As String
    Recipient = mvarRecipient
End Property
 
Public Property Get Connected() As Boolean
    Connected = mvarConnected
End Property
 
Public Sub OpenMail()
    Reply = 0
    'connect to SMTP server
    Winsock.Connect mvarSMTPhost, 25
    If WaitFor(Connection) Then
        GiveError
        Exit Sub
    End If
    'send hello and wait for OK
    Winsock.SendData "helo " & mvarSMTPhost & vbCrLf
    If WaitFor(OK) Then
        GiveError
        Winsock.Close
        Exit Sub
    End If
    'send sender's name
    MyName = WhoAmI
     If InStr(mvarSender, "@") = 0 Then
        Winsock.SendData "Mail From:<" & mvarSender & "@" & MyName & ">" & vbCrLf
    Else
        Winsock.SendData "Mail From:<" & mvarSender & ">" & vbCrLf
    End If
    If WaitFor(OK) Then
        GiveError
        Winsock.Close
        Exit Sub
    End If
    'send recipient
    Winsock.SendData "RCPT TO:<" & mvarRecipient & ">" & vbCrLf
    If WaitFor(OK) Then
        GiveError
        Winsock.Close
        Exit Sub
    End If
    'make ready for data
    Winsock.SendData "Data" & vbCrLf
    If WaitFor(ReadyforData) Then
        GiveError
        Winsock.Close
        Exit Sub
    End If
    'Send Date:
    Winsock.SendData "Date: " & Format(Date, " dd mmm yy ") & Time & vbCrLf
    'To:
    Winsock.SendData "TO:<" & mvarRecipient & ">" & vbCrLf
    'From:
    Winsock.SendData "From: <" & mvarSender & "@" & MyName & ">" & vbCrLf
    'Subject:
    If Not mvarSubject = "" Then Winsock.SendData "Subject:" & mvarSubject & vbCrLf
    mvarConnected = True
End Sub
 
Private Function WhoAmI() As String
Dim X As Integer, Y As Integer
    X = InStr(Message, "Hello")
    Y = InStr(Message, "[")
    If X = 0 Or Y = 0 Then
        WhoAmI = Winsock.LocalIP
    Else
        X = X + 6
        Y = Y - 1 - X
        WhoAmI = Mid$(Message, X, Y)
    End If
End Function
 
Public Sub CloseMail()
    Winsock.SendData "." & vbCrLf
    If WaitFor(OK) Then
        GiveError
        Exit Sub
    End If
    Winsock.SendData "QUIT"
    Winsock.Close
End Sub
 
Private Sub GiveError()
 Dim Message As String
 Select Case Reply
 Case Is = 10061
  Message = "Can't Connect to " & mvarSMTPhost
 Case Is = 11001
  Message = mvarSMTPhost & " is not a valid name or address."
 Case Is = 550
  Message = "User " & mvarRecipient & " not known to server."
 Case Is = 0
  Message = "Timeout waiting for server response"
 Case Is = 500
  Message = "Server does not recognize a command sent."
 Case Is = 553
  Message = "Invalid recipient name"
 Case Is = 1
  Message = "You must set Host, Recipient and Sender before connecting"
 Case Else
  Message = "Mail tool error."
 End Select
 
 RaiseEvent Error(Reply, Message)
End Sub
 
Private Sub Class_Initialize()
    Set Winsock = New MSWinsockLib.Winsock
End Sub
 
Private Sub Winsock_DataArrival(ByVal bytesTotal As Long)
Dim X As String
    Winsock.GetData X
    Reply = Val(X)
    X = Trim$(Mid(X, 4))
    RaiseEvent ServerResponse(Reply, X)
    Message = X
End Sub
 
Private Sub Winsock_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)
    Reply = Number
End Sub