至顶网›软件频道 ›基础软件›用VB设计有安全认证服务的Email

用VB设计有安全认证服务的Email

扫一扫
分享文章到微信
扫一扫
关注官方公众号
至顶头条

国内各大免费邮箱提供商纷纷开始采用ESMTP的方式设计E-mail收发服务

作者：刘静来源：yesky 2007年10月15日

关键字：

三、代码实现

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 ' 设置协议为TCP
　　Winsock1.RemoteHost = MailServerName ' SMTP地址
　　Winsock1.RemotePort = 25 ' SMTP端口
　　Winsock1.Connect ' 开始连接
　　WaitFor ("220")
　　StatusTxt.Caption = "Connecting...."
　　StatusTxt.Refresh
　　Winsock1.SendData ("HELO worldcomputers.com" + vbCrLf)
　　WaitFor ("250")
　　StatusTxt.Caption = "Connected"
　　StatusTxt.Refresh

　　If NeedCheck = 1 Then
　　　'进行校验LOGIN
　　　Winsock1.SendData ("AUTH LOGIN" + vbCrLf)
　　　StatusTxt.Caption = "LOGIN ESMTP"
　　　StatusTxt.Refresh
　　　WaitFor ("334")
　　　'输入用户名
　　　Winsock1.SendData (Base64EncodeString(EmialUsername) + vbCrLf)
　　　StatusTxt.Caption = "username"
　　　StatusTxt.Refresh
　　　WaitFor ("334")
　　　'输入用户口令
　　　Winsock1.SendData (Base64EncodeString(EmialPassword) + vbCrLf)
　　　StatusTxt.Caption = "password"
　　　StatusTxt.Refresh
　　　WaitFor ("235")
　　End If

　　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)
　'检查是否收到SMTP服务器的返回代码
　Start = Timer
　While Len(Response) = 0
　　Tmr = Timer - Start
　　DoEvents
　　If Tmr > 50 Then
　　　MsgBox "SMTP service error, timed out while waiting for response" _
　　　　　　, 64, MsgTitle
　　　Exit Sub
　　End If
　Wend

　While Left(Response, 3) <> ResponseCode
　　Tmr = Timer - Start
　　DoEvents
　　If Tmr > 50 Then
　　　MsgBox "SMTP service error, impromper response code. _
　　　　　　　Code should have been: " + ResponseCode + " Code recieved: " _
　　　　　　　+ Response, 64, MsgTitle
　　　Exit Sub
　　End If
　Wend
　Response = "" ' Response清空
End Sub

Private Sub Command1_Click()
　SendEmail txtEmailServer.Text, txtFromName.Text, _
　txtFromEmailAddress.Text, txtToEmailAddress.Text, _
　txtToEmailAddress.Text, txtEmailSubject.Text, _
　txtEmailBodyOfMessage.Text, txtFromEmialPassword.Text, _
　txtFromEmialUsername.Text, EmailNeedCheck.Value
　StatusTxt.Caption = "Mail Sent"
　StatusTxt.Refresh
　Beep
　Close
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
　' 接收SMTP服务器的信息
　Winsock1.GetData Response
End Sub

　　在运行本程序前请先上网，根据实际值填写文本框后点击发送邮件按钮，至此一封具有安全认证服务功能的Email发出了。

　　下载本文源代码,此程序在Windows Me 、XP /VB6.0中调试通过

查看本文来源

VIP专区

VIP用户

普通用户

邮件订阅

如果您非常迫切的想了解IT领域最新产品与技术信息，那么订阅至顶网技术邮件将是您的最佳途径之一。

重磅专题

往期文章

用VB设计有安全认证服务的Email

业界热点: