mail2000.pas

Documentation included in source code (mail2000.pas).

    FTextHTML: TStringList;
    FTextPlainPart: TMailPart;
    FTextHTMLPart: TMailPart;
    FMixedPart: TMailPart;
    FRelatedPart: TMailPart;
    FAlternativePart: TMailPart;
    FTextFather: TMailPart;
    FCharset: String;
    FOnProgress: TProgressEvent;
    FNameCount: Integer;
    FToList: TMailRecipients;
    FCcList: TMailRecipients;
    FBccList: TMailRecipients;
    FTextEncoding: TEncodingType;

    FNeedRebuild: Boolean;
    FNeedNormalize: Boolean;
    FNeedFindParts: Boolean;

    function GetDestName(Field: String; const Index: Integer): String;
    function GetDestAddress(Field: String; const Index: Integer): String;

    function GetReceivedCount: Integer;
    function GetReceived(const Index: Integer): TReceived;

    function GetAttach(const FileName: String): TMailPart;

    function GetFromName: String;
    function GetFromAddress: String;
    function GetReplyToName: String;
    function GetReplyToAddress: String;
    function GetSubject: String;
    function GetDate: TDateTime;
    function GetMessageId: String;

    procedure PutText(Text: String; var Part: TMailPart; Content: String);
    procedure RemoveText(var Part: TMailPart);

    procedure SetSubject(const Subject: String);
    procedure SetDate(const Date: TDateTime);
    procedure SetMessageId(const MessageId: String);

  public

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure SetFrom(const Name, Address: String);                           // Create/modify the From: field
    procedure SetReplyTo(const Name, Address: String);                        // Create/modify the Reply-To: field

    procedure FindParts;                                                      // Search for the attachments and texts
    procedure Normalize(const Kind: TNormalizer = nrFirst);                                                      // Reconstruct message on Mail2000 standards (multipart/mixed)
    procedure RebuildBody;                                                    // Build the raw mail body according to mailparts
    procedure Reset;                                                          // Clear all stored data in the object
    procedure SetTextPlain(const Text: String);                               // Create/modify a mailpart for text/plain (doesn't rebuild body)
    procedure SetTextHTML(const Text: String);                                // Create/modify a mailpart for text/html (doesn't rebuild body)
    procedure RemoveTextPlain;                                                // Remove the text/plain mailpart (doesn't rebuild body)
    procedure RemoveTextHTML;                                                 // Remove the text/html mailpart (doesn't rebuild body)

    procedure AttachFile(const FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
              // Create a mailpart and encode a file on it (doesn't rebuild body)
    procedure AttachString(const Text, FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
              // Create a mailpart and encode a string on it (doesn't rebuild body)
    procedure AttachStream(const AStream: TStream; const FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
              // Create a mailpart and encode a stream on it (doesn't rebuild body)
    procedure DetachFile(const FileName: String);
              // Remove attached file from message by name
    procedure DetachFileIndex(const Index: Integer);
              // Remove attached file from message by index of AttachList

    procedure AddHop(const From, By, Aplic, Address: String);                 // Add a 'Received:' in message header

    property Received[const Index: Integer]: TReceived read GetReceived;      // Retrieve the n-th 'Received' header
    property ReceivedCount: Integer read GetReceivedCount;                    // Count the instances of 'Received' fields (hops)
    property AttachByName[const FileName: String]: TMailPart read GetAttach;  // Returns the MailPart of an attachment by filename
    property ToList: TMailRecipients read FToList;                            // Handling of To: recipients
    property CcList: TMailRecipients read FCcList;                            // Handling of Cc: recipients
    property BccList: TMailRecipients read FBccList;                          // Handling of Bcc: recipients

    property MessageSource: String read GetSource write SetSource;
    property FromName: String read GetFromName;                               // Retrieve the From: name
    property FromAddress: String read GetFromAddress;                         // Retrieve the From: address
    property ReplyToName: String read GetReplyToName;                         // Retrieve the Reply-To: name
    property ReplyToAddress: String read GetReplyToAddress;                   // Retrieve the Reply-To: address
    property Subject: String read GetSubject write SetSubject;                // Retrieve or set the Subject: string
    property Date: TDateTime read GetDate write SetDate;                      // Retrieve or set the Date: in TDateTime format
    property MessageId: String read GetMessageId write SetMessageId;          // Retrieve or set the Message-Id:
    property AttachList: TMailPartList read FAttachList;                      // A list of all attached files
    property TextPlain: TStringList read FTextPlain;                          // A StringList with the text/plain from message
    property TextHTML: TStringList read FTextHTML;                            // A StringList with the text/html from message
    property TextPlainPart: TMailPart read FTextPlainPart;                    // The text/plain part
    property TextHTMLPart: TMailPart read FTextHTMLPart;                      // The text/html part
    property NeedRebuild: Boolean read FNeedRebuild;                          // True if RebuildBody is needed
    property NeedNormalize: Boolean read FNeedNormalize;                      // True if message needs to be normalized
    property NeedFindParts: Boolean read FNeedFindParts;                      // True if message has parts to be searched for

  published

    property Charset: String read FCharSet write FCharset;                       // Charset to build headers and text
    property TextEncoding: TEncodingType read FTextEncoding write FTextEncoding; // How text will be encoded
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;      // Occurs when storing message in memory
  end;

  { TSocketTalk }

  TSocketTalk = class(TComponent)
  private

    FTimeOut: Integer;
    FExpectedEnd: String;
    FLastResponse: String;
    FDataSize: Integer;
    FPacketSize: Integer;
    FTalkError: TTalkError;
    FSessionState: TSessionState;
    FClientSocket: TClientSocket;
    FWaitingServer: Boolean;
    FTimer: TTimer;
    FServerResult: Boolean;

    FOnProgress: TProgressEvent;
    FOnEndOfData: TEndOfDataEvent;
    FOnSocketTalkError: TSocketTalkErrorEvent;
    FOnReceiveData: TReceiveDataEvent;
    FOnDisconnect: TNotifyEvent;

    procedure SocketRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SocketError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure Timer(Sender: TObject);

  public

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Talk(Buffer, EndStr: String; SessionState: TSessionState);
    procedure Cancel;
    procedure ForceState(SessionState: TSessionState);
    procedure WaitServer;

    property LastResponse: String read FLastResponse;
    property DataSize: Integer read FDataSize write FDataSize;
    property PacketSize: Integer read FPacketSize write FPacketSize;
    property TimeOut: Integer read FTimeOut write FTimeOut;
    property TalkError: TTalkError read FTalkError;
    property ClientSocket: TClientSocket read FClientSocket;
    property ServerResult: Boolean read FServerResult;

    property OnEndOfData: TEndOfDataEvent read FOnEndOfData write FOnEndOfData;
    property OnSocketTalkError: TSocketTalkErrorEvent read FOnSocketTalkError write FOnSocketTalkError;
    property OnReceiveData: TReceiveDataEvent read FOnReceiveData write FOnReceiveData;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
    property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
  end;

  { TPOP2000 }

  TPOP2000 = class(TComponent)
  private

    FMailMessage: TMailMessage2000;

    FSessionMessageCount: Integer;
    FSessionMessageSize: TMessageSize;
    FSessionConnected: Boolean;
    FSessionLogged: Boolean;
    FLastMessage: String;
    FSocketTalk: TSocketTalk;

    FUserName: String;
    FPassword: String;
    FPort: Integer;
    FHost: String;
    FDeleteOnRetrieve: Boolean;

    procedure EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
    procedure SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
    procedure ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
    procedure SocketDisconnect(Sender: TObject);

    function GetTimeOut: Integer;
    procedure SetTimeOut(Value: Integer);

    function GetProgress: TProgressEvent;
    procedure SetProgress(Value: TProgressEvent);

    function GetLastResponse: String;

  public

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function Connect: Boolean;                                                // Connect to mail server
    function Login: Boolean;                                                  // Autenticate to mail server
    function Quit: Boolean;                                                   // Logout and disconnect

    procedure Abort;                                                          // Force disconnect

    function RetrieveMessage(Number: Integer): Boolean;                       // Retrieve mail number # and put in MailMessage
    function RetrieveHeader(Number: Integer; Lines: Integer = 0): Boolean;    // Retrieve header and put in MailMessage
    function DeleteMessage(Number: Integer): Boolean;                         // Delete mail number #
    function GetUIDL(Number: Integer): String;                                // Get UIDL from mail number #

    property SessionMessageCount: Integer read FSessionMessageCount;          // Number of messages found on server
    property SessionMessageSize: TMessageSize read FSessionMessageSize;       // Dynamic array with size of the messages
    property SessionConnected: Boolean read FSessionConnected;                // True if conencted to server
    property SessionLogged: Boolean read FSessionLogged;                      // True if autenticated on server
    property LastMessage: String read FLastMessage;                           // Last integral message text
    property LastResponse: String read GetLastResponse;                       // Last string received from server

  published

    property UserName: String read FUserName write FUserName;                 // User name to login on server
    property Password: String read FPassword write FPassword;                 // Password
    property Port: Integer read FPort write FPort;                            // Port (usualy 110)
    property Host: String read FHost write FHost;                             // Host address
    property MailMessage: TMailMessage2000 read FMailMessage write FMailMessage;  // Message retrieved
    property TimeOut: Integer read GetTimeOut write SetTimeOut;               // Max time to wait for server reply in seconds
    property OnProgress: TProgressEvent read GetProgress write SetProgress;   // Occurs when receiving data from server
    property DeleteOnRetrieve: Boolean read FDeleteOnRetrieve write FDeleteOnRetrieve;  // If message will be deleted after successful retrieve
  end;

  { TSMTP2000 }

  TSMTP2000 = class(TComponent)
  private

    FMailMessage: TMailMessage2000;

    FSessionConnected: Boolean;
    FSocketTalk: TSocketTalk;
    FPacketSize: Integer;

    FPort: Integer;
    FHost: String;

    procedure EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
    procedure SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
    procedure ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
    procedure SocketDisconnect(Sender: TObject);

    function GetTimeOut: Integer;
    procedure SetTimeOut(Value: Integer);

    function GetProgress: TProgressEvent;
    procedure SetProgress(Value: TProgressEvent);

    function GetLastResponse: String;

  public

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function Connect: Boolean;                                                // Connect to mail server
    function Quit: Boolean;                                                   // Disconnect

    procedure Abort;                                                          // Force disconnect

    function SendMessage: Boolean;                                            // Send MailMessage to server
    function SendMessageTo(const From, Dests: String): Boolean;               // Send MailMessage to specified recipients
    function SendStringTo(const Msg, From, Dests: String): Boolean;           // Send string to specified recipients

    property SessionConnected: Boolean read FSessionConnected;                // True if conencted to server
    property LastResponse: String read GetLastResponse;                       // Last string received from server

  published

    property Port: Integer read FPort write FPort;                            // Port (usualy 25)
    property Host: String read FHost write FHost;                             // Host address
    property TimeOut: Integer read GetTimeOut write SetTimeOut;               // Max time to wait for a response in seconds
    property MailMessage: TMailMessage2000 read FMailMessage write FMailMessage;  // Message to send
    property PacketSize: Integer read FPacketSize write FPacketSize;          // Size of packets to send to server
    property OnProgress: TProgressEvent read GetProgress write SetProgress;   // Occurs when sending data to server
  end;

procedure Register;

{ Very useful functions ====================================================== }

function DecodeLine7Bit(Texto: String): String; forward;
function EncodeLine7Bit(Texto, Charset: String): String; forward;
function DecodeQuotedPrintable(Texto: String): String; forward;
function EncodeQuotedPrintable(Texto: String; HeaderLine: Boolean): String; forward;
function DecodeUUCODE(Encoded: PChar; Decoded: TMemoryStream): Boolean; forward;
function DecodeLineUUCODE(const Buffer: String; Decoded: PChar): Integer; forward;
function DecodeLineBASE64(const Buffer: String; Decoded: PChar): Integer; forward;
function EncodeBASE64(Encoded: TMemoryStream {TMailText}; Decoded: TMemoryStream): Integer; forward;
function NormalizeLabel(Texto: String): String; forward;
function LabelValue(cLabel: String): String; forward;
function WriteLabelValue(cLabel, Value: String): String; forward;
function LabelParamValue(cLabel, cParam: String): String; forward;
function WriteLabelParamValue(cLabel, cParam, Value: String): String; forward;
function GetTimeZoneBias: Double; forward;
function PadL(const Str: String; const Tam: Integer; const PadStr: String): String; forward;
function GetMimeType(const FileName: String): String; forward;
function GetMimeExtension(const MimeType: String): String; forward;
function GenerateBoundary: String; forward;
function SearchStringList(Lista: TStringList; const Chave: String; const Occorrence: Integer = 0): Integer; forward;
procedure DataLine(var Data, Line: String; var nPos: Integer); forward;
procedure DataLinePChar(const Data: PChar; const TotalLength: Integer; var LinePos, LineLen: Integer; var Line: PChar; var DataEnd: Boolean); forward;
function IsIPAddress(const SS: String): Boolean; forward;
function TrimSpace(const S: string): string; forward;
function TrimLeftSpace(const S: string): string; forward;
function TrimRightSpace(const S: string): string; forward;
function MailDateToDelphiDate(const DateStr: String): TDateTime; forward;
function DelphiDateToMailDate(const Date: TDateTime): String; forward;
function ValidFileName(FileName: String): String; forward;
function WrapHeader(Text: String): String; forward;

implementation

const
  _C_T  = 'Content-Type';
  _C_D  = 'Content-Disposition';
  _C_TE = 'Content-Transfer-Encoding';
  _C_ID = 'Content-ID';
  _C_L  = 'Content-Length';
  _CONT = 'Content-';
  _FFR  = 'From';
  _FRT  = 'Reply-To';
  _M_V  = 'Mime-Version';
  _M_ID = 'Message-ID';
  _X_M  = 'X-Mailer';

const
  _TXT  = 'text/';
  _T_P  = 'text/plain';
  _T_H  = 'text/html';
  _MP   = 'multipart/';
  _M_M  = 'multipart/mixed';
  _M_A  = 'multipart/alternative';
  _M_R  = 'multipart/related';
  _M_RP = 'multipart/report';
  _A_OS = 'application/octet-stream';
  _BDRY = 'boundary';
  _ATCH = 'attachment';
  _INLN = 'inline';

const
  _MIME_Msg = 'This is a multipart message in mime format.'#13#10;
  _XMailer  = 'Mail2000 1.10 http://groups.yahoo.com/group/tmail2000';
  _TXTFN    = 'textpart.txt';
  _HTMLFN   = 'textpart.htm';
  _CHARSET  = 'iso-8859-1';
  _DATAEND1 = #13#10'.'#13#10;
  _DATAEND2 = #13#10'..'#13#10;
  _LINELEN  = 72;

procedure Register;
begin

  RegisterComponents('Mail2000', [TPOP2000, TSMTP2000, TMailMessage2000]);
end;

// Decode an encoded field e.g. =?iso-8859-1?x?xxxxxx=?=

function DecodeLine7Bit(Texto: String): String;
var
  Buffer: PChar;
  Encoding: Char;
  Size: Integer;
  nPos0: Integer;
  nPos1: Integer;
  nPos2: Integer;
  nPos3: Integer;
  Found: Boolean;

begin

  Result := TrimSpace(Texto);

  repeat

    nPos0 := Pos('=?', Result);
    Found := False;

    if nPos0 > 0 then
    begin

      nPos1 := Pos('?', Copy(Result, nPos0+2, Length(Result)))+nPos0+1;
      nPos2 := Pos('?=', Copy(Result, nPos1+1, Length(Result)))+nPos1;
      nPos3 := Pos('?', Copy(Result, nPos2+1, Length(Result)))+nPos2;

      if nPos3 > nPos2 then
      begin

        if Length(Result) > nPos3 then
        begin

          if Result[nPos3+1] = '=' then
          begin

            nPos2 := nPos3;
          end;
        end;
      end;

      if (nPos1 > nPos0) and (nPos2 > nPos1) then
      begin

        Texto := Copy(Result, nPos1+1, nPos2-nPos1-1);

        if (Length(Texto) >= 2) and (Texto[2] = '?') and (UpCase(Texto[1]) in ['B', 'Q', 'U']) then
        begin

          Encoding := UpCase(Texto[1]);
        end
        else
        begin

          Encoding := 'Q';
        end;

        Texto := Copy(Texto, 3, Length(Texto)-2);

        case Encoding of

          'B':
          begin

            GetMem(Buffer, Length(Texto));
            Size := DecodeLineBASE64(Texto, Buffer);
            Buffer[Size] := #0;
            Texto := String(Buffer);
          end;

          'Q':
          begin

            while Pos('_', Texto) > 0 do
              Texto[Pos('_', Texto)] := #32;

            Texto := DecodeQuotedPrintable(Texto);
          end;

          'U':
          begin

            GetMem(Buffer, Length(Texto));
            Size := DecodeLineUUCODE(Texto, Buffer);
            Buffer[Size] := #0;
            Texto := String(Buffer);
          end;
        end;

        Result := Copy(Result, 1, nPos0-1)+Texto+Copy(Result,nPos2+2,Length(Result));
        Found := True;
      end;
    end;

  until not Found;
end;

// Encode a header field e.g. =?iso-8859-1?x?xxxxxx=?=

function EncodeLine7Bit(Texto, Charset: String): String;
var
  Loop: Integer;
  Encode: Boolean;

begin

  Encode := False;

  for Loop := 1 to Length(Texto) do
    if (Ord(Texto[Loop]) > 127) or (Ord(Texto[Loop]) < 32) then
    begin

      Encode := True;
      Break;
    end;

  if Encode then
    Result := '=?'+Charset+'?Q?'+EncodeQuotedPrintable(Texto, True)+'?='
  else
    Result := Texto;
end;

// Decode a quoted-printable encoded string