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
