以往各网站的EMail系统均是根据标准的SMTP编写的，现在为了更有效地抑制垃圾邮件的泛滥，国内各大免费邮箱提供商纷纷开始采用ESMTP的方式设计E-mail收发服务。发送邮件需要对用户的身份进行验证，如果帐号和密码有误，ESMTP则拒绝发送该邮件返回553错误代码。通过对的分析我找到设计这样EMail的方法，我们可以用Visual Baisc轻松完成。
一、 相关知识的介绍 ESMTP（Extension SMTP）即认证的邮件传输方式，是邮件系统为了限制非本系统的正式用户利用本系统散发垃圾邮件或其他不当行为而开设的一项认证服务。它与传统的SMTP方式相比，主要的不同有两点：
1． 支持8－bit MIME格式的编码。
2． 支持用户身份的验证。
多了一道用户身份的验证手续，验证之后的邮件发送过程与传统的SMTP方式一致。为了方便用户的使用，绝大多数的ESMTP服务器都继承了POP3服务器的帐号和密码设置体系，也就是说收发邮件都用同一个帐号和密码。
根据[RFC 2554]规范，SMTP的认证功能主要是增加了AUTH命令。AUTH命令有多种用法，而且有多种认证机制。AUTH支持的认证机制主要有LOGIN，CRAM-MD5[注1]等。LOGIN应该是大多数免费邮件服务器都支持的，网易与新浪都支持。下面主要针对LOGIN方式进行介绍，其它方式请根据相应的RFC 规范进行修改。
LOGIN 方式口令-应答过程如下(S:表示服务器返回，C:表示客户端发送)
1． C: AUTH LOGIN
2． S: 334 dXNlcm5hbWU6
3． C: dXNlcm5hbWU6
4． S: 334 cGFzc3dvcmQ6
5． C: cGFzc3dvcmQ6
6． S: 235 Authentication successful.
(1)． 为客户端向服务器发送认证指令。
(2)． 服务端返回base64编码串，成功码为334。编码字符串解码后为"username:"，说明要求客户端发送用户名。
(3)． 客户端发送用base64编码的用户名，此处为"username:"。
(4)． 服务端返回base64编码串，成功码为334。编码字符串解码后为"password:"，说明要求客户端发送用户口令。
(5)． 客户端发送用base64编码的口令，此处为"password:"。
(6)． 成功后，服务端返回码为235，表示认证成功可以发送邮件了
二、 具体步骤 1． 启动VB6新建一工程，加载控件Microsoft Winsock Control 6.0，在窗体上放置1个
Winsock控件，8个TextBox控件，按下图修改他们的属性，CheckBox控件用于选择是否需要认证服务。
三、 代码实现 Public Response As String, Reply As Integer, DateNow As String
Public Start As Single, Tmr As Single
'API-函数
'Private Declare Function ArrPtr Lib "msvbvm50.dll" _
' Alias "VarPtr" (Ptr() As Any) As Long '<-- VB5
'ArrPtr:取数组的地址
Private Declare Function ArrPtr Lib "msvbvm60.dll" _
Alias "VarPtr" (Ptr() As Any) As Long '<-- VB6
'PokeLng:转换地址内容
Private Declare Sub PokeLng Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal Addr As Long, Source As Long, _
Optional ByVal Bytes As Long = 4)
'Base64:
Private Base64EncodeByte(0 To 63) As Byte
Private Base64EncodeWord(0 To 63) As Integer
Const Base64EmptyByte As Byte = 61
Const Base64EmptyWord As Integer = 61
Public Sub Base64Init()
'建立Base64码数组
Const Chars64 As String _
= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" _
& "abcdefghijklmnopqrstuvwxyz" _
& "0123456789+/"
Static i As Long
Dim Code As Integer
If i Then Exit Sub
For i = 0 To 63
Code = Asc(Mid$(Chars64, i + 1, 1))
Base64EncodeByte(i) = Code
Base64EncodeWord(i) = Code
Next i
End Sub
Public Static Function Base64EncodeString(ByRef Text As String) As String
'Base64码转换函数
Dim Chars() As Integer
Dim SavePtr As Long
Dim SADescrPtr As Long
Dim DataPtr As Long
Dim CountPtr As Long
Dim TextLen As Long
Dim i As Long
Dim Chars64() As Integer
Dim SavePtr64 As Long
Dim SADescrPtr64 As Long
Dim DataPtr64 As Long
Dim CountPtr64 As Long
Dim TextLen64 As Long
Dim j As Long
Dim b1 As Integer
Dim b2 As Integer
Dim b3 As Integer
j = 0
TextLen = Len(Text)
If TextLen = 0 Then Exit Function
'输入字符串校验
TextLen64 = ((TextLen + 2) \ 3) * 4
'字符串转换为Base64码后的长度
Base64EncodeString = Space$(TextLen64)
If SavePtr = 0 Then
ReDim Chars(1 To 1)
SavePtr = VarPtr(Chars(1))
'SavePtr=*Chars(1)
PokeLng VarPtr(SADescrPtr), ByVal ArrPtr(Chars)
'*SADescrPtr=*Chars
DataPtr = SADescrPtr + 12
CountPtr = SADescrPtr + 16
ReDim Chars64(0 To 0)
SavePtr64 = VarPtr(Chars64(0))
'SavePtr64=*Chars64(0)
PokeLng VarPtr(SADescrPtr64), ByVal ArrPtr(Chars64)
'*SADescrPtr64=*Chars64
DataPtr64 = SADescrPtr64 + 12
CountPtr64 = SADescrPtr64 + 16
End If
PokeLng DataPtr, StrPtr(Text)
'DataPtr=*Text
PokeLng CountPtr, TextLen
'CountPtr=TextLen
PokeLng DataPtr64, StrPtr(Base64EncodeString)
'DataPtr64=*Base64EncodeString
PokeLng CountPtr64, TextLen64
'CountPtr64=Textlen64
Base64Init
'输入字符串转换为Base64码
For i = 1 To TextLen - 2 Step 3
b1 = Chars(i)
b2 = Chars(i + 1)
b3 = Chars(i + 2)
'Base64-Bytes:
Chars64(j) = Base64EncodeWord(b1 \ &H4)
Chars64(j + 1) = Base64EncodeWord((b1 And &H3) * &H10 + b2 \ &H10)
Chars64(j + 2) = Base64EncodeWord((b2 And &HF) * &H4 + b3 \ &H40)
Chars64(j + 3) = Base64EncodeWord(b3 And &H3F)
j = j + 4
Next i
'继续将未转换完的输入字符串转换为Base64码
Select Case TextLen - i
Case 0 '2 Bytes
b1 = Chars(i)
Chars64(j) = Base64EncodeWord(b1 \ &H4)
Chars64(j + 1) = Base64EncodeByte((b1 And &H3) * &H10)
Chars64(j + 2) = Base64EmptyWord
Chars64(j + 3) = Base64EmptyWord
Case 1 '1 Byte
b1 = Chars(i)
b2 = Chars(i + 1)
Chars64(j) = Base64EncodeWord(b1 \ &H4)
Chars64(j + 1) = Base64EncodeWord((b1 And &H3) * &H10 + b2 \ &H10)
Chars64(j + 2) = Base64EncodeWord((b2 And &HF) * &H4)
Chars64(j + 3) = Base64EmptyWord
End Select
'返回转换成Base64码的字符串
PokeLng DataPtr64, SavePtr64
PokeLng CountPtr64, 1
PokeLng DataPtr, SavePtr
PokeLng CountPtr, 1
End Function
Sub SendEmail(MailServerName As String, FromName As String, _
FromEmailAddress As String, ToName As String, ToEmailAddress As String, _
EmailSubject As String, EmailBodyOfMessage As String, EmialPassword As String, _
EmialUsername As String, NeedCheck As Integer)
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
Winsock1.LocalPort = 0 '用端口0来动态的建立连接
If Winsock1.State = sckClosed Then '检查winsock的状态是否为关
'发件人地址
first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf
'收件人地址
Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf
'时间
Third = "Date:" + Chr(32) + Format(Date, "Ddd") & ", " & _
Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") _
& "" & " -0600" + vbCrLf
'发件人
Fourth = "From:" + Chr(32) + FromName + vbCrLf
'收件人
Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf
'主题
Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf
'正文
Seventh = EmailBodyOfMessage + vbCrLf
Ninth = "X-Mailer: lj v 2.x" + vbCrLf
Eighth = Fourth + Third + Ninth + Fifth + Sixth
Winsock1.Protocol = sckTCPProtocol ' 设置
【责编:admin】
--------------------next---------------------
