怎么用WINSOCK API编支持SMTP认证的邮件发送程序

to: redbirdli(火鸟)
   欢迎。我看了SankeMail的SMTP部分代码，
  FSocket.Port := StrToIntDef( FPort, 25);
  if sak_IsIPAddress(FHost) then
  begin
    FSocket.Address := FHost;        // Roger
    FSocket.Host := '';              // Roger
  end else
  begin
    FSocket.Host := FHost;          // Sergio
    FSocket.Address := '';          // Sergio
  end;  FSMTPError := false;
  try
    FSocket.Open;
  except
    FSMTPError := True;
    exit;
  end;  FSocket是TClientSocket的实例。如果服务器需要验证信息，那么FSocket.Open就会出现异常，“服务器积极拒绝”之类的信息。我不知道验证信息应该在什么地方发出，你不妨把代码或者思路贴出来。
在VB窗体上放一个Winsock控件,调用SendEmail就可以了:
Delphi下做也一样的:Option Explicit
Dim Response As String, Reply As Integer, DateNow As String
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, Ninth As String
Dim Start As Single, Tmr As Single
'sock.tag 作为sock的超时值处理
'me.Tag 作为sock的发送完成标识
Public Function SendEmail(MailServerName As String, FromEmailAddress As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String, Port As Integer, TimeOut As Integer) As Integer
On Error GoTo senderr
Dim itmp As Integer
  ' Check to see if socet is closed
   Do Until sock.State = sckClosed
     sock.Close
   Loop

    sock.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail pre program start
    SendEmail = 5
    DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
    first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf ' Get who's sending E-Mail address
    Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf ' Get who mail is going to
    Third = "Date:" + Chr(32) + DateNow + vbCrLf ' Date when being sent
'    Fourth = "From:" + Chr(32) + FromName + vbCrLf ' Who's Sending
'    Fifth = "To:" + Chr(32) + ToName + vbCrLf ' Who it going to
    Fourth = "From:" + Chr(32) + FromEmailAddress + vbCrLf ' Who's Sending
    Fifth = "To:" + Chr(32) + ToEmailAddress + vbCrLf ' Who it going to

    Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf ' Subject of E-Mail
    Seventh = EmailBodyOfMessage + vbCrLf ' E-mail message body
    Ninth = "X-Mailer: DP Connection MailSender" + vbCrLf ' What program sent the e-mail, customize this
    Eighth = Fourth + Third + Ninth + Fifth + Sixth  ' Combine for proper SMTP sending    sock.Protocol = sckTCPProtocol ' Set protocol for sending
    sock.RemoteHost = MailServerName ' Set the server address
    sock.RemotePort = Port ' Set the SMTP Port
    sock.Connect ' Start connection
   sock.Tag = TimeOut
  itmp = WaitFor("220")
    If itmp <> 0 Then
      SendEmail = itmp
      Exit Function
    End If
'    StatusTxt.Caption = "Connecting...."
'    StatusTxt.Refresh

    sock.SendData ("HELO worldcomputers.com" + vbCrLf)  itmp = WaitFor("250")
    If itmp <> 0 Then
      SendEmail = itmp
      Exit Function
    End If
'    StatusTxt.Caption = "Connected"
'    StatusTxt.Refresh    sock.SendData (first)'    StatusTxt.Caption = "Sending Message"
'    StatusTxt.Refresh   itmp = WaitFor("250")
    If itmp <> 0 Then
      SendEmail = itmp
      Exit Function
    End If
    sock.SendData (Second)   itmp = WaitFor("250")
    If itmp <> 0 Then
      SendEmail = itmp
      Exit Function
    End If
    sock.SendData ("data" + vbCrLf)

   itmp = WaitFor("354")
    If itmp <> 0 Then
      SendEmail = itmp
      Exit Function
    End If    sock.SendData (Eighth + vbCrLf)
    sock.SendData (Seventh + vbCrLf)
    sock.SendData ("." + vbCrLf)   itmp = WaitFor("250")
    If itmp <> 0 Then
      SendEmail = itmp
      Exit Function
    End If
    sock.SendData ("quit" + vbCrLf)

'    StatusTxt.Caption = "Disconnecting"
'    StatusTxt.Refresh   itmp = WaitFor("221")
    If itmp <> 0 Then
      SendEmail = itmp
      Exit Function
    End If
    sock.Close
    SendEmail = 0
    Exit Function
senderr:
End FunctionPrivate Function WaitFor(ResponseCode As String) As Integer
    Start = Timer ' Time event so won't get stuck in loop
    While Len(Response) = 0
        Tmr = Timer - Start
        DoEvents ' Let System keep checking for incoming response **IMPORTANT**
        If Tmr > sock.Tag Then  ' Time in seconds to wait
          '  MsgBox "SMTP service error, timed out while waiting for response", 64
             WaitFor = 4
            Exit Function
        End If
    Wend
    While Left(Response, 3) <> ResponseCode
        Tmr = Timer - Start
        DoEvents
        If Tmr > sock.Tag Then
            'MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64
            WaitFor = 5
            Exit Function
        End If
    Wend
Response = "" ' Sent response code to blank **IMPORTANT**
WaitFor = 0
End Function
Private Sub sock_DataArrival(ByVal bytesTotal As Long)  sock.GetData ResponseEnd SubPrivate Sub sock_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)
    sock.Tag = 0
End SubPrivate Sub sock_SendComplete()
   Me.Tag = 0
End Sub

调试易

怎么用WINSOCK API编支持SMTP认证的邮件发送程序

解决方案 »