unit tmail;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  Tsocketc, NWinsock, StdCtrls;

{ If Using the Delphi 32 Winsock.pas }
type
     _Socket = TSocket;
     fd_set = TFDSet;
     Pfd_set = PFDSet;
     timeval = TTimeVal;
     hostent = THostEnt;
     netent = TNetEnt;
     servent = TServEnt;
     protoent = TProtoEnt;
     in_addr = TInAddr;
     Pin_addr = PInAddr;
     Sockaddr_in = TSockAddrIn;
     PSockaddr_in = PSockAddrIn;
     WSADATA = TWSAData;
     LPWSADATA = PWSAData;
     sockaddr = TSockAddr;
     sockproto = TSockProto;
     linger = TLinger;
     LPSOCKADDR = ^sockaddr;
     LPSOCKADDR_IN = ^sockaddr_in;
     LPLINGER = ^linger;
     LPIN_ADDR = ^in_addr;
     LPFD_SET = ^fd_set;
     LPHOSTENT = ^hostent;
     LPSERVENT = ^servent;
     LPPROTOENT = ^protoent;
     LPTIMEVAL = ^timeval;
{ End of Delphi 32 Winsock.pas compatability type definitions }
const
  SKT_NOOP = 0;
  SKT_GETHOSTADDR = 1;
  SKT_CONNECTTOHOST = 2;
  SKT_SENDPACKET = 3;
  SKT_RECVPACKET = 4;
{Constant declarations to represent SMTP commands. These keep
track of the command last issued so that responses received
from the server can be directed to the appropriate procedure}
  MAIL_NOOP = 0;
  MAIL_CONNECT = 1;
  MAIL_HELO = 2;
  MAIL_MAILFROM = 3;
  MAIL_RCPTTO = 4;
  MAIL_RCPTCC = 5;
  MAIL_DATA = 6;
  MAIL_RSET = 7;
  MAIL_SEND = 8;
  MAIL_SOML = 9;
  MAIL_SAML = 10;
  MAIL_VRFY = 11;
  MAIL_EXPN = 12;
  MAIL_HELP = 13;
  MAIL_TURN = 14;
  MAIL_QUIT = 15;
  MAIL_SENDINGHEADER = 16;
  MAIL_SENDINGMESSAGE = 17;
{User-defined event declarations for socket events. The first is to be
used for the primary socket, the second is to be used for address
lookup notifications}
  UWM_SOCKETEVENT = WM_USER + 500;
  UWM_ADDRSOCKETEVENT = WM_USER + 501;
type
  TSMTPClient = class(TForm)
    Label1: TLabel;
    stStatus: TLabel;
    Label2: TLabel;
    sleHost: TEdit;
    Label3: TLabel;
    sleLogin: TEdit;
    Label5: TLabel;
    sleTo: TEdit;
    Label6: TLabel;
    sleCC: TEdit;
    Label7: TLabel;
    sleSubject: TEdit;
    Label8: TLabel;
    mleMessage: TMemo;
    cbClose: TButton;
    cbSend: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ProcessHostLookup;
    procedure ProcessHostConnect;
    procedure ClearBuffer(DirtyBuffer: Pchar; BufLength: Integer);
    procedure ProcessHostWelcome;
    procedure ProcessHostSend;
    procedure ProcessHostHelo;
    procedure ProcessHostMailFrom;
    procedure ProcessHostRcptTo;
    procedure SendMessageHeader;
    procedure SendMessageText;
    procedure ProcessHostData;
    procedure ProcessHostQuit;
    procedure ProcessHostReceive;
    procedure cbCloseClick(Sender: TObject);
    procedure cbSendClick(Sender: TObject);
  private
    { Private declarations }
    isConnectionSocket: _SOCKET;
    ibConnected: Boolean;
    iiMailStatus: Integer;
    procedure UWMSocketEvent(var Msg: TMessage); message UWM_SOCKETEVENT;
    procedure UWMAddrSocketEvent(var Msg: TMessage); message UWM_ADDRSOCKETEVENT;
  public
    { Public declarations }
    NetSocket: _TSocket;
    ReceiveBuffer: array[0..8192] of Char;
    TempBuffer: array[0..8192] of Char;
  end;

var
  SMTPClient: TSMTPClient;

implementation

{$R *.DFM}

procedure TSMTPClient.FormCreate(Sender: TObject);
begin
   ibConnected := FALSE;
   iiMailStatus := MAIL_NOOP;
   {Create the NetSocket class}
   NetSocket := _TSocket.Create;
   {Initialize the WinSock system}
   if not NetSocket.InitializeSocket then
      Close;
end;

procedure TSMTPClient.FormDestroy(Sender: TObject);
begin
     {Cleanup the WinSock interface and system}
     NetSocket.ShutdownSocket;
     NetSocket.Free;
end;

procedure TSMTPClient.ProcessHostLookup;
begin
   {We have received the host address, now we need to connect to it.}
   stStatus.Caption := 'Connecting To Host';
   stStatus.Update;
   if (NetSocket.ProcessHostAddress = TRUE) then
   begin
      {Connect to the host computer}
      isConnectionSocket := NetSocket.OpenSocketConnection(Handle, UWM_SOCKETEVENT, SKT_CONNECTTOHOST, IPPORT_SMTP);
   end
   else
   begin
      stStatus.Caption := 'Cannot Find Host Address';
      stStatus.Update;
   end;
end;

procedure TSMTPClient.ProcessHostConnect;
begin
   {We have connected to the other computer, so update the display}
   stStatus.Caption := 'Receiving Welcome From Host';
   stStatus.Update;
   iiMailStatus := MAIL_CONNECT;
   ClearBuffer(ReceiveBuffer, 8192);
end;

procedure TSMTPClient.ClearBuffer(DirtyBuffer: Pchar; BufLength: Integer);
var
   liCurPos: Integer;
   lcNullChar: Char;
begin
   {Initialize the position pointer to 0}
   liCurPos := 0;
   {Create a null character}
   lcNullChar := Char(0);
   {Loop through the entire buffer passed in, setting each character
   equal to the null character}
   while (liCurPos < BufLength) do
   begin
      DirtyBuffer^ := lcNullChar;
      Inc(liCurPos);
      Inc(DirtyBuffer);
   end;
end;

procedure TSMTPClient.ProcessHostWelcome;
var
   lsWelcomeMsg, lsRetnCode: String;
   lsHostName: array[0..79] of Char;
begin
   {Convert the received message to a Pascal string}
   lsWelcomeMsg := StrPas(ReceiveBuffer);
   {Copy the response code into the lsRetnCode variable}
   lsRetnCode := Copy(lsWelcomeMsg, 1, 3);
   {Check to see what was returned}
   case StrToInt(lsRetnCode) of
      {Positive Response, you are connected}
      220: ibConnected := TRUE;
      {Negative Response, you are not connected}
      421: ibConnected := FALSE;
   end;
   {Set the command status flag to NOOP}
   iiMailStatus := MAIL_NOOP;
   {Display the response message}
   stStatus.Caption := lsWelcomeMsg;
   stStatus.Update;
   {If you are connected}
   if ibConnected then
   begin
      {Set the command status flag to indicate that you sent an HELO}
      iiMailStatus := MAIL_HELO;
      {Get the name of the computer on which you are running}
      if (gethostname(lsHostName, sizeof(lsHostName)) = SOCKET_ERROR) then
         ShowMessage(NetSocket.SocketError)
      else
      begin
         {Send HELO command to mail server, telling it who you are}
         NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                              'HELO ' + StrPas(lsHostName), SKT_SENDPACKET);
         {Clear the receive buffer}
         ClearBuffer(ReceiveBuffer, 8192);
      end;
   end;
end;

procedure TSMTPClient.ProcessHostSend;
begin
      if (iiMailStatus <> MAIL_NOOP) then
      begin
         ClearBuffer(ReceiveBuffer, 8192);
      end;
end;

procedure TSMTPClient.ProcessHostHelo;
var
   lsWelcomeMsg, lsRetnCode: String;
   lbContinue: boolean;
begin
   {Initialize the continue flag to FALSE, so that you have to alter it
   only in the event of a positive response from the server}
   lbContinue := FALSE;
   {Convert the received message to a Pascal string}
   lsWelcomeMsg := StrPas(ReceiveBuffer);
   {Copy the response code into the lsRetnCode variable}
   lsRetnCode := Copy(lsWelcomeMsg, 1, 3);
   {Check to see what was returned}
   case StrToInt(lsRetnCode) of
      {Positive Response, set the continue flag to TRUE}
      250: lbContinue := TRUE;
      {Some sort of Negative Response}
      421: ;
      500: ;
      501: ;
      504: ;
   end;
   {Set the command status flag to NOOP}
   iiMailStatus := MAIL_NOOP;
   {Display the response message}
   stStatus.Caption := lsWelcomeMsg;
   stStatus.Update;
   {If you are continuing}
   if lbContinue then
   begin
      {Set the command status flag to indicate that you sent a MAIL FROM}
      iiMailStatus := MAIL_MAILFROM;
      {Send the MAIL command to the mail server,
      telling it who the sender is}
      NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          'MAIL FROM:<' + sleLogin.text + '>', SKT_SENDPACKET);
      {Clear the receive buffer}
      ClearBuffer(ReceiveBuffer, 8192);
   end;
end;

procedure TSMTPClient.ProcessHostMailFrom;
var
   lsWelcomeMsg, lsRetnCode: String;
   lbContinue: boolean;
begin
   {Initialize the continue flag to FALSE, so that you have to alter it
   only in the event of a positive response from the server}
   lbContinue := FALSE;
   {Convert the received message to a Pascal string}
   lsWelcomeMsg := StrPas(ReceiveBuffer);
   {Copy the response code into the lsRetnCode variable}
   lsRetnCode := Copy(lsWelcomeMsg, 1, 3);
   {Check to see what was returned}
   case StrToInt(lsRetnCode) of
      {Positive Response, set the continue flag to TRUE}
      250: lbContinue := TRUE;
      {Some sort of Negative Response}
      421: ;
      451: ;
      452: ;
      500: ;
      501: ;
      552: ;
   end;
   {Set the command status flag to NOOP}
   iiMailStatus := MAIL_NOOP;
   {Display the response message}
   stStatus.Caption := lsWelcomeMsg;
   stStatus.Update;
   {If you are continuing}
   if lbContinue then
   begin
      {Set the command status flag to indicate that you sent an RCPT TO}
      iiMailStatus := MAIL_RCPTTO;
      {Send the RCPT command to the mail server, telling it to whom
       to send the message}
      NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          'RCPT TO:<' + sleTo.text + '>', SKT_SENDPACKET);
      {Clear the receive buffer}
      ClearBuffer(ReceiveBuffer, 8192);
   end;
end;

procedure TSMTPClient.ProcessHostRcptTo;
var
   lsWelcomeMsg, lsRetnCode: String;
   lbContinue: boolean;
begin
   {Initialize the continue flag to FALSE, so that you have to alter it
   only in the event of a positive response from the server}
   lbContinue := FALSE;
   {Convert the received message to a Pascal string}
   lsWelcomeMsg := StrPas(ReceiveBuffer);
   {Copy the response code into the lsRetnCode variable}
   lsRetnCode := Copy(lsWelcomeMsg, 1, 3);
   {Check to see what was returned}
   case StrToInt(lsRetnCode) of
      {Positive Response, set the continue flag to TRUE}
      250: lbContinue := TRUE;
      251: lbContinue := TRUE;
      {Some sort of Negative Response}
      421: ;
      450: ;
      451: ;
      452: ;
      500: ;
      501: ;
      503: ;
      550: ;
      551: ;
      552: ;
      553: ;
   end;
   {Display the response message}
   stStatus.Caption := lsWelcomeMsg;
   stStatus.Update;
   {If you are continuing}
   if lbContinue then
   begin
      {Do you have a CC address to which to send this message?}
      if ((Length(sleCC.Text) > 0) and (iiMailStatus = MAIL_RCPTTO)) then
      begin
         {If you have a CC address, tell the server about it}
         {Set command status flag to indicate that you sent RCPT TO}
         iiMailStatus := MAIL_RCPTCC;
         {Send the RCPT command to the mail server, telling it whom 
         to send the message} 
         NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          'RCPT TO:<' + sleCC.text + '>', SKT_SENDPACKET);
         {Clear the receive buffer}
         ClearBuffer(ReceiveBuffer, 8192);
      end
      else
      begin
         {No one else to whom to send the message, so send the message}
         {Set the command status flag to indicate that you sent a DATA}
         iiMailStatus := MAIL_DATA;
         {Send the DATA command to the mail server, telling it that you
         are about to send the message}
         NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          'DATA', SKT_SENDPACKET);
         {Clear the receive buffer}
         ClearBuffer(ReceiveBuffer, 8192);
      end;
   end;
end;

procedure TSMTPClient.SendMessageHeader;
var
   lsHeader: String;
begin
   {Place the socket into synchronous mode}
   WSAAsyncSelect(isConnectionSocket, handle, 0, 0);
   {Build the TO header line, adding a carriage return and line feed to
   the end of the line}
   lsHeader := 'To: ' + sleTo.Text + #13#10;
   {Add the FROM header line. This is the end of what you are sending as
   one packet, so you need to be sure not to add on a carriage return and
   line-feed characters, or else the mail servers and readers will think
   this is the end of the message header}
   lsHeader := lsHeader + 'From: ' + sleLogin.Text;
   {Send the two header lines already assembled to the server}
   NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          lsHeader, SKT_SENDPACKET);
   {Build the SUBJECT header line. You have to assume that the line
   could be long, so you don't want to add anything else to this
   header line. Because you are not adding anything else, you need
   to be sure not to add the carriage-return and line-feed characters 
   because you are not finished with the header section}
   lsHeader := 'Subject: ' + sleSubject.Text;
   {Send the Subject line to the server}
   NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          lsHeader, SKT_SENDPACKET);
   {Build a couple of header lines stating which mailer created this
   message. These header lines are not standard, but are user-defined
   extensions, as has become fairly common practice. These lines
   are the end of the message header, so you want to add the
   carriage-return and line-feed characters to the end of each line.
   Therefore, when the SocketSend procedure adds another carriage-
   return and newline pair, it is seen as the separator between 
   the message header and body}
   lsHeader := 'X-Sender: ' + #13#10;
   lsHeader := lsHeader + 'X-Mailer: Delphi SMTP Mailer v1.0' + #13#10;
   {Send the last two lines of the message header}
   NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          lsHeader, SKT_SENDPACKET);
   {Call the SendMessageText procedure, to send the message body}
   SendMessageText;
end;

procedure TSMTPClient.SendMessageText;
var
   lsText: String;
   liTextPos, liBufPos, liTextLength: Integer;
   lpcMessBuf: PChar;
   lpcBufArray: Array[0..245] of Char;
begin
   {Get the message body length}
   liTextLength := mleMessage.GetTextLen;
   {allocate a Pchar buffer to hold the entire message}
   lpcMessBuf := StrAlloc((liTextLength + 1));
   {Copy the message from the TMEMO field into the allocated buffer}
   mleMessage.GetTextBuf(lpcMessBuf, (liTextlength + 1));
   {Is the message longer than 245 characters long? The reason for the
   245 character limit is to ensure that the strings can be converted 
   to Pascal strings and passed to the SocketSend function, so that
   you don't have to build a new send function. The 245 character limit
   leaves enough room to add  the carriage-return and line-feed 
   characters to the end of each line}
   if (liTextLength > 245) then
   begin
      {If so, you need to break it up into multiple messages}
      liTextPos := 0;
      {Loop until you reach the end of the message}
      while (liTextPos < liTextLength) do
      begin
         {Copy the text into the smaller buffer, limiting the copied text
         to 245 character strings}
         liBufPos := 0;
         while ((liBufPos < 245) and (liTextPos < liTextLength)) do
         begin
            lpcBufArray[liBufPos] := lpcMessBuf[liTextPos];
            Inc(liBufPos);
            Inc(liTextPos);
         end;
         {Mark the end of the copied string with a NULL character}
         lpcBufArray[liBufPos] := #0;
         {Convert the string into a Pascal string}
         lsText := StrPas(lpcBufArray);
         {Send the string to the server}
         NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          lsText, SKT_SENDPACKET);
      end;
      {You have reached the end of the message; send the message-
      termination string}
      NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          #13#10 + '.' + #13#10, SKT_SENDPACKET);
   end
   else
   begin
      {The message is shorter than 245 characters; send it with
      the message-termination string on the end}
      lsText := StrPas(lpcMessBuf) + #13#10 + '.' + #13#10;
      NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          lsText, SKT_SENDPACKET);
   end;
   {Release the memory allocated for holding the message body}
   StrDispose(lpcMessBuf);
   {Clear the receive buffer}
   ClearBuffer(ReceiveBuffer, 8192);
   {Set the socket into synchronous mode, so that the following recv()
   will wait until a response is received from the server}
   WSAAsyncSelect(isConnectionSocket, handle, 0, 0);
   {Receive the response to the message body from the server}
   liTextLength := recv(isConnectionSocket, ReceiveBuffer, 8192, 0);
   {Did you receive anything?}
   if (liTextLength > 0) then
      {If so, call ProcessHostData to process the response}
      ProcessHostData
   else
   begin
      {if you didn't receive anything, try again}
      liTextLength := recv(isConnectionSocket, ReceiveBuffer, 8192, 0);
      {Did we receive anything this time?}
      if (liTextLength > 0) then
         {If so, call ProcessHostData to process the response}
         ProcessHostData
      else
      begin
         {You still didn't receive a response from the message}
         {Set the command status flag to indicate that you sent a QUIT}
         iiMailStatus := MAIL_QUIT;
         {Send the QUIT command to the mail server, telling the server
         that you have finished your session}
         NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          'QUIT', SKT_SENDPACKET);
         {Clear the receive buffer}
         ClearBuffer(ReceiveBuffer, 8192);
      end;
   end;
end;

procedure TSMTPClient.ProcessHostData;
var
   lsWelcomeMsg, lsRetnCode: String;
   lbContinue: boolean;
   lbDone: boolean;
begin
   {Initialize the continue flag to FALSE, so that you have to alter it
   only in the event of a positive response from the server}
   lbContinue := FALSE;
   lbDone := FALSE;
   {Convert the received message to a Pascal string}
   lsWelcomeMsg := StrPas(ReceiveBuffer);
   {Copy the response code into the lsRetnCode variable}
   lsRetnCode := Copy(lsWelcomeMsg, 1, 3);
   {Check to see what was returned}
   case StrToInt(lsRetnCode) of
      {Positive Response, set the continue flag to TRUE}
      250:
      begin
         lbContinue := TRUE;
         {250 also means that the server has received the complete
         message. You are finished and can end this session}
         lbDone := TRUE;
      end;
      354: lbContinue := TRUE;
      {Some sort of Negative Response}
      421: ;
      451: ;
      452: ;
      500: ;
      501: ;
      503: ;
      552: ;
      554: ;
   end;
   {Set the command status flag to NOOP}
   iiMailStatus := MAIL_NOOP;
   {Display the response message}
   stStatus.Caption := lsWelcomeMsg;
   stStatus.Update;
   {If you are continuing}
   if lbContinue then
   begin
      {Are you finished sending the message?}
      if lbDone then
      begin
         {Set the command status flag to indicate that you sent a QUIT}
         iiMailStatus := MAIL_QUIT;
         {Send the QUIT command to the mail server, telling the server
         that you have finished your session}
         NetSocket.SocketSend(isConnectionSocket, handle, UWM_SOCKETEVENT,
                          'QUIT', SKT_SENDPACKET);
         {Clear the receive buffer}
         ClearBuffer(ReceiveBuffer, 8192);
      end
      else
         {No, you haven't sent the message yet, the server is ready to
         receive the message}
         SendMessageHeader;
   end;
end;

procedure TSMTPClient.ProcessHostQuit;
var
   lsWelcomeMsg, lsRetnCode: String;
   lbContinue: boolean;
begin
   {Initialize the continue flag to FALSE, so that you have to alter it
   only in the event of a positive response from the server}
   lbContinue := FALSE;
   {Convert the received message to a Pascal string}
   lsWelcomeMsg := StrPas(ReceiveBuffer);
   {Copy the response code into the lsRetnCode variable}
   lsRetnCode := Copy(lsWelcomeMsg, 1, 3);
   {Check to see what was returned}
   case StrToInt(lsRetnCode) of
      {Positive Response, set the continue flag to TRUE}
      221: lbContinue := TRUE;
      {Some sort of Negative Response}
      500: ;
   end;
   {Set the command status flag to NOOP}
   iiMailStatus := MAIL_NOOP;
   {Display the response message}
   stStatus.Caption := lsWelcomeMsg;
   stStatus.Update;
   {Clear all of the message specific data from the screen}
   sleTo.Clear;
   sleCC.Clear;
   sleSubject.Clear;
   mleMessage.Clear;
   {If you are connected}
   if ibConnected then
   begin
      {shut down and close the socket connection to the server}
      shutdown(isConnectionSocket, 0);
      NetSocket.CloseSocketConnection(isConnectionSocket);
   end;
end;

procedure TSMTPClient.ProcessHostReceive;
var
   lsRetnStr: String;
   liCarRetnPos: Integer;
begin
   try
      {Receive any incoming data}
      liCarRetnPos := recv(isConnectionSocket, ReceiveBuffer, 8192, 0);
      ReceiveBuffer[liCarRetnPos] := Char(0);
      {you have received an FD_READ event, so  check whether you
      received anything}
      if (ReceiveBuffer[0] = Char(0)) then
      begin
         {Clear the receive buffer}
         ClearBuffer(ReceiveBuffer, 8192);
      end
      else
      begin
         {You received data, so  check which command you issued and
         call the appropriate procedure}
         case iiMailStatus of
            MAIL_NOOP: ;
            MAIL_CONNECT: ProcessHostWelcome;
            MAIL_HELO: ProcessHostHelo;
            MAIL_MAILFROM: ProcessHostMailFrom;
            MAIL_RCPTTO: ProcessHostRcptTo;
            MAIL_RCPTCC: ProcessHostRcptTo;
            MAIL_DATA: ProcessHostData;
            MAIL_RSET:;
            MAIL_SEND:;
            MAIL_SOML:;
            MAIL_SAML:;
            MAIL_VRFY:;
            MAIL_EXPN:;
            MAIL_HELP:;
            MAIL_TURN:;
            MAIL_QUIT: ProcessHostQuit;
         end;
      end;
   except
      {Clear the receive buffer}
      ClearBuffer(ReceiveBuffer, 8192);
   end;
end;

procedure TSMTPClient.UWMSocketEvent(var Msg: TMessage);
begin
   case Msg.LParamLo of
      FD_READ: ProcessHostReceive;
      FD_WRITE: ProcessHostSend;
      FD_CONNECT: ProcessHostConnect;
      FD_CLOSE: ;
   end;
end;

procedure TSMTPClient.UWMAddrSocketEvent(var Msg: TMessage);
begin
   if (Msg.lParamHi = 0) then
      ProcessHostLookup;
end;

procedure TSMTPClient.cbCloseClick(Sender: TObject);
begin
   Close;
end;

procedure TSMTPClient.cbSendClick(Sender: TObject);
begin
   if ((Length(sleHost.Text) > 0) and
      (Length(sleLogin.Text) > 0)) then
   begin
      stStatus.Caption := 'Looking Up Host Address';
      stStatus.Update;
      iiMailStatus := MAIL_CONNECT;
      NetSocket.GetHostAddress(Handle, UWM_ADDRSOCKETEVENT, sleHost.text, SKT_GETHOSTADDR);
   end;
end;

end.
