怎样做一个有身份验证的SMTP邮件发送软件

平时都做免验证的,但是现在服务器大都不支持了,怎样做一个有身份验证的SMTP邮件发送软件?

解决方案 »

  1.   

    http://expert.csdn.net/Expert/FAQ/FAQ_Index.asp?id=15580
    http://expert.csdn.net/Expert/FAQ/FAQ_Index.asp?id=50746
      

  2.   

    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 = 61Public 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 SubPublic 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 FunctionSub 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 SubSub 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 SubPrivate 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 SubPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    　' 接收SMTP服务器的信息
    　Winsock1.GetData Response
    End Sub 　　在运行本程序前请先上网，根据实际值填写文本框后点击发送邮件按钮，至此一封具有安全认证服务功能的Email发出了