Use Socket in VB6.0 to send emails with SMTP authentication

In this example, there are many versions on the Internet, but the exception management is not very good. The code here is a little bit organized by me. The authentication process is included. I think SMTP is usually used for authentication now. If you do not want to authenticate, you only need to remove the corresponding lines.

The Code is as follows:

Dim Response As String, Reply As Integer
Dim DateNow As String, first As String, Second As String, Third As String
Dim Fourth As String, th 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 per 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"

'Get who's sending e-mail address
First = "mail from:" + CHR (32) + fromemailaddress + vbcrlf
'Get who mail is going
Second = "rcpt to:" + CHR (32) + toemailaddress + vbcrlf
'Date when being sent
Third = "Date:" + CHR (32) + datenow + vbcrlf
'Who's sending
Fourth = "from:" + CHR (32) + fromname + vbcrlf
'Who it going
Th = "to:" + CHR (32) + tonametxt + vbcrlf
'Subject of E-mail
Sixth = "Subject:" + CHR (32) + emailsubject + vbcrlf
'E-mail message body
Seventh = EmailBodyOfMessage + vbCrLf
'What program sent the e-mail, customize this
Ninth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf
'Combine for proper SMTP sending
Eighth = Fourth + Third + Ninth + Th + Sixth

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 xxx.gov.cn" + vbCrLf)
WaitFor ("250 ")
StatusTxt. Caption = "Connected"
StatusTxt. Refresh

Winsock1.SendData ("auth login" + vbCrLf)
WaitFor ("334 ")
StatusTxt. Caption = "Sending auth login"
StatusTxt. Refresh

Winsock1.SendData (Base64_Encode ("danny@xxx.gov.cn") + vbCrLf)
WaitFor ("334 ")
StatusTxt. Caption = "Sending Username"
StatusTxt. Refresh

Winsock1.SendData (Base64_Encode ("danny") + vbCrLf)
WaitFor ("235 ")
StatusTxt. Caption = "Sending Password"
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 shocould have been:" + ResponseCode + "Code recieved:" + Response, 64, MsgTitle
Exit Sub
End If
Wend
Response = "" 'sent response code to blank ** IMPORTANT **
End Sub

Private Sub commandementclick ()
SendEmail txtEmailServer. Text, txtFromName. Text, txtFromEmailAddress. Text, txtToEmailAddress. Text, txtToEmailAddress. Text, txtEmailSubject. Text, response. Text 'msgbox ("Mail Sent ")
StatusTxt. Caption = "Mail Sent"
StatusTxt. Refresh
Beep
Close
End Sub

Private Sub Winsock1_DataArrival (ByVal bytesTotal As Long)
Winsock1.GetData Response 'check for incoming response * IMPORTANT *
End Sub

Private Function Base64_Encode (strSource) As String 'base6 Encryption Algorithm
Const BASE64_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789 + /"
Dim strTempLine As String
Dim j As Integer
For j = 1 To (Len (strSource)-Len (strSource) Mod 3) Step 3
StrTempLine = strTempLine + Mid (BASE64_TABLE, (Asc (Mid (strSource, j, 1)/4) + 1, 1)
StrTempLine = strTempLine + Mid (BASE64_TABLE, (Asc (Mid (strSource, j, 1) Mod 4) * 16 _
+ Asc (Mid (strSource, j + 1, 1)/16) + 1, 1)
StrTempLine = strTempLine + Mid (BASE64_TABLE, (Asc (Mid (strSource, j + 1, 1) Mod 16) * 4 _
+ Asc (Mid (strSource, j + 2, 1)/64) + 1, 1)
StrTempLine = strTempLine + Mid (BASE64_TABLE, (Asc (Mid (strSource, j + 2, 1) Mod 64) + 1, 1)
Next j
If Not (Len (strSource) Mod 3) = 0 Then
If (Len (strSource) Mod 3) = 2 Then
StrTempLine = strTempLine + Mid (BASE64_TABLE, (Asc (Mid (strSource, j, 1)/4) + 1, 1)
StrTempLine = strTempLine + Mid (BASE64_TABLE, (Asc (Mid (strSource, j, 1) Mod 4) * 16 _
+ Asc (Mid (strSource, j + 1, 1)/16 + 1, 1)
StrTempLine = strTempLine + Mid (BASE64_TABLE, (Asc (Mid (strSource, j + 1, 1) Mod 16) * 4 + 1, 1)
StrTempLine = strTempLine & "="
ElseIf (Len (strSource) Mod 3) = 1 Then
StrTempLine = strTempLine + Mid (BASE64_TABLE, Asc (Mid (strSource, j, 1)/4 + 1, 1)
StrTempLine = strTempLine + Mid (BASE64_TABLE, (Asc (Mid (strSource, j, 1) Mod 4) * 16 + 1, 1)
Strtempline = strtempline & "="
End if
End if
Base64_encode = strtempline
End Function

Trackback: http://tb.blog.csdn.net/TrackBack.aspx? Postid = 470493