Create a new class module and paste this source code into it. You should name this class cSimpleSMTP. If you have any questions, email us at help@codeoftheweek.com
'----------------------------------------------------------------------
'
' Module Name: cSimpleSMTP
' Written By: C&D Programming Corp.
' Create Date: 4/99
' Copyright: Copyright 1999 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
'
' Enhancements to make this more robust:
' - Timeout errors within the SendData and RecData functions
' it should eventually error out with a sckError, but it
' would be nice to make it user controllable.
' - Better mechanism to filter the error messages up to the
' client.
' - Add ability to send attachments (although that would
' be more than "SimpleSMTP")
' - Ability to send to multiple recipients
'
'
'
' Sample Usage:
'
' Dim SMTP As New cSimpleSMTP
'
' Set SMTP.WinSockControl = Form1.wsControl
' SMTP.SMTPHost = "smtp.codeoftheweek.com"
' SMTP.DomainName = "codeoftheweek.com"
' SMTP.FromUsername = "info@codeoftheweek.com"
' SMTP.ToUsername = "billgates@microsoft.com"
' SMTP.Subject = "Where's VB7?"
' SMTP.MessageText = "Bill, Please get VB7 out ASAP. Thanks, COTW"
' SMTP.SendMessage
'
'
Option Explicit
' GetTickCount returns the number of milliseconds that Windows
' since Windows has started.
'
' The internal timer will wrap around to zero if Windows is
' run continuously for approximately 49 days.
'
Private Declare Function GetTickCount Lib "kernel32" () As Long
Public SMTPHost As String ' IP address or domain name
Public SMTPPort As Long ' port number of the SMTP server. Default is 25.
Public DomainName As String ' like abc.com (this is the domain you are sending from)
Public FromUsername As String ' any username in the format abc@abc.com
' should be your username.
Public ToUsername As String ' any username in the format abc@abc.com
Public Subject As String ' any text string
Public MessageText As String ' any message text
' Winsock control which was dropped on a form
'
Public WithEvents WinSockControl As Winsock
' some status flags to make it easier to manage certain states.
Private mbSendComplete As Boolean
Private mbRecComplete As Boolean
Private Sub LogMessage(sData As String)
Debug.Print sData
' you can do anything you need to here to save the log data or
' dump it into a text box or something like that.
' maybe raise an event to show status messages to a client application.
End Sub
Private Sub WinSockControl_DataArrival(ByVal bytesTotal As Long)
Dim sData As String
Dim lCode As Long
WinSockControl.GetData sData, vbString, bytesTotal
On Error Resume Next
lCode = Val(sData) ' will return non-zero if the string begins with a
' number. We trap for an error just in case someone
' tries to send a very large numeric string. We do
' not want this routine to crash out.
If Err Then
lCode = 0
End If
On Error GoTo 0
LogMessage "Received " & bytesTotal & " bytes of data."
LogMessage "Status Code: " & lCode ' useful for working with the SMTP host
LogMessage "Raw Data: " & sData
mbRecComplete = True
End Sub
Private Sub WinSockControl_SendComplete()
mbSendComplete = True
mbRecComplete = False
End Sub
Public Sub SendMessage()
Dim sData As String
Dim sMsg As String
Static bInRoutine As Boolean
If bInRoutine Then
Err.Raise 5, "SendMessage", "Already in process of sending message."
End If
bInRoutine = True
WinSockControl.RemoteHost = SMTPHost
WinSockControl.RemotePort = SMTPPort
WinSockControl.Connect
If WaitFor(sckConnected) Then
SendData "HELO " & DomainName & vbCrLf
RecData
SendData "MAIL FROM: " & FromUsername & vbCrLf
RecData
SendData "RCPT TO: " & ToUsername & vbCrLf
RecData
SendData "DATA" & vbCrLf
RecData
SendData "Subject: " & Subject & vbCrLf & MessageText & vbCrLf & "." & vbCrLf
RecData
SendData "QUIT" & vbCrLf
RecData
End If
Wait 2 ' let's make sure the data is completely sent.
WinSockControl.Close
bInRoutine = False
Exit Sub
Handler:
bInRoutine = False
Err.Raise Err.Number, "SendMessage", Err.Description
If WinSockControl.State <> sckClosed Then
WinSockControl.Close
End If
End Sub
Private Function RecData() As Boolean
While Not mbRecComplete And WinSockControl.State <> sckError
DoEvents
Wend
End Function
Private Function SendData(sData As String)
mbSendComplete = False
WinSockControl.SendData sData
While Not mbSendComplete And WinSockControl.State <> sckError
DoEvents
Wend
End Function
Private Function WaitFor(lState As Long) As Boolean
While WinSockControl.State <> lState And WinSockControl.State <> sckError
DoEvents
Wend
If WinSockControl.State = sckError Then
WaitFor = False
Else
WaitFor = True
End If
End Function
Private Sub Class_Initialize()
SMTPPort = 25
End Sub
Private Sub WinSockControl_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)
LogMessage "error: " & Number & " - " & Description & " source: " & Source
End Sub
Private Sub WinSockControl_SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
LogMessage "sending: " & bytesSent & " remaining: " & bytesRemaining
End Sub
Private Sub WinSockControl_Close()
LogMessage "closed"
End Sub
Private Sub WinSockControl_Connect()
LogMessage "connected"
End Sub
Private Sub WinSockControl_ConnectionRequest(ByVal requestID As Long)
LogMessage "connection request " & requestID
End Sub
'----------------------------------------------------------------------
'
' Module Name: basWait - integrated into cSimpleMAPI for
' ease of distribution.
' Written By: C&D Programming Corp.
' Create Date: 5/98
' Copyright: Copyright 1998 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
Public Function Wait(ByVal lSeconds As Long, _
Optional ByRef bAbortFlag As Boolean = False, _
Optional ByRef lElapsed As Long) As Boolean
Dim lStartTime As Long
lStartTime = GetTickCount
lElapsed = 0
While (lElapsed < lSeconds) And (Not bAbortFlag)
' Convert to seconds (use integer math for extra speed
lElapsed = (GetTickCount - lStartTime) \ 1000
DoEvents
Wend
Wait = Not bAbortFlag
End Function