clmailmessage.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

{
  Clever Internet Suite Version 6.2
  Copyright (C) 1999 - 2006 Clever Components
  www.CleverComponents.com
}

unit clMailMessage;

interface

{$I clVer.inc}

uses
  Classes, SysUtils, clEncoder;

type
  TclMessagePriority = (mpLow, mpNormal, mpHigh);
  TclMessageFormat = (mfNone, mfMIME, mfUUencode);

  TclMailMessage = class;
  TclMessageBodies = class;
  TclMessageBody = class;

  TclGetBodyStreamEvent = procedure (Sender: TObject; ABody: TclMessageBody;
    const AFileName: string; var AData: TStream; var Handled: Boolean) of object;

  TclBodyDataAddedEvent = procedure (Sender: TObject; ABody: TclMessageBody; AData: TStream) of object;

  TclBodyEncodingProgress = procedure (Sender: TObject; ABodyNo, ABytesProceed, ATotalBytes: Integer) of object;

  EclMailMessageError = class(Exception);

  TclMessageBody = class(TPersistent)
  private
    FOwner: TclMessageBodies;
    FContentType: string;
    FEncoding: TclEncodeMethod;
    FEncoder: TclEncoder;
    FContentDisposition: string;
    FExtraFields: TStrings;
    FKnownFields: TStrings;
    FRawHeader: TStrings;
    FEncodedSize: Integer;
    FEncodedLines: Integer;
    FRawBodyStart: Integer;
    procedure SetContentType(const Value: string);
    procedure SetContentDisposition(const Value: string);
    procedure SetEncoding(const Value: TclEncodeMethod);
    procedure DoOnListChanged(Sender: TObject);
    procedure DoOnEncoderProgress(Sender: TObject; ABytesProceed, ATotalBytes: Integer);
    function GetIndex: Integer;
    procedure SetExtraFields(const Value: TStrings);
  protected
    procedure SetListChangedEvent(AList: TStringList);
    function GetMailMessage: TclMailMessage;
    procedure ReadData(Reader: TReader); virtual;
    procedure WriteData(Writer: TWriter); virtual;
    function HasEncodedData: Boolean; virtual;
    procedure AddData(AData: TStream; AEncodedLines: Integer);
    function GetData: TStream;
    function GetEncoding: TclEncodeMethod; virtual;
    procedure AssignBodyHeader(ASource: TStrings); virtual;
    procedure ParseBodyHeader(ABodyPos: Integer; ASource, AFieldList: TStrings); virtual;
    function GetSourceStream: TStream; virtual; abstract;
    function GetDestinationStream: TStream; virtual; abstract;
    procedure BeforeDataAdded(AData: TStream); virtual;
    procedure DataAdded(AData: TStream); virtual;
    procedure DecodeData(ASource, ADestination: TStream); virtual;
    procedure EncodeData(ASource, ADestination: TStream); virtual;
    procedure DoCreate; virtual;
    procedure RegisterField(const AField: string);
    procedure RegisterFields; virtual;
    property KnownFields: TStrings read FKnownFields;
  public
    constructor Create(AOwner: TclMessageBodies); virtual;
    destructor Destroy(); override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear(); virtual;
    property ContentType: string read FContentType write SetContentType;
    property ContentDisposition: string read FContentDisposition write SetContentDisposition;
    property Encoding: TclEncodeMethod read GetEncoding write SetEncoding;
    property Index: Integer read GetIndex;
    property ExtraFields: TStrings read FExtraFields write SetExtraFields;
    property EncodedSize: Integer read FEncodedSize;
    property EncodedLines: Integer read FEncodedLines;
    property RawHeader: TStrings read FRawHeader;
    property RawBodyStart: Integer read FRawBodyStart;
  end;

  TclMessageBodyClass = class of TclMessageBody;

  TclTextBody = class(TclMessageBody)
  private
    FCharSet: string;
    FStrings: TStrings;
    procedure SetStrings(const Value: TStrings);
    procedure SetCharSet(const Value: string);
  protected
    procedure ReadData(Reader: TReader); override;
    procedure WriteData(Writer: TWriter); override;
    procedure AssignBodyHeader(ASource: TStrings); override;
    procedure ParseBodyHeader(ABodyPos: Integer; ASource, AFieldList: TStrings); override;
    function GetSourceStream: TStream; override;
    function GetDestinationStream: TStream; override;
    procedure DataAdded(AData: TStream); override;
    procedure DoCreate; override;
  public
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear; override;
    property Strings: TStrings read FStrings write SetStrings;
    property CharSet: string read FCharSet write SetCharSet;
  end;

  TclMultipartBody = class(TclMessageBody)
  private
    FBodies: TclMessageBodies;
    FMailMessage: TclMailMessage;
    FContentSubType: string;
    procedure SetBodies(const Value: TclMessageBodies);
    procedure SetBoundary(const Value: string);
    procedure SetContentSubType(const Value: string);
    function GetBoundary: string;
    procedure DoOnGetDataStream(Sender: TObject; ABody: TclMessageBody;
      const AFileName: string; var AStream: TStream; var Handled: Boolean);
    procedure DoOnGetDataSourceStream(Sender: TObject; ABody: TclMessageBody;
      const AFileName: string; var AStream: TStream; var Handled: Boolean);
    procedure DoOnDataAdded(Sender: TObject; ABody: TclMessageBody; AData: TStream);
  protected
    procedure ReadData(Reader: TReader); override;
    procedure WriteData(Writer: TWriter); override;
    function HasEncodedData: Boolean; override;
    procedure AssignBodyHeader(ASource: TStrings); override;
    procedure ParseBodyHeader(ABodyPos: Integer; ASource, AFieldList: TStrings); override;
    function GetSourceStream: TStream; override;
    function GetDestinationStream: TStream; override;
    procedure DataAdded(AData: TStream); override;
    procedure DoCreate; override;
  public
    destructor Destroy(); override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear(); override;
    property Boundary: string read GetBoundary;
    property Bodies: TclMessageBodies read FBodies write SetBodies;
    property ContentSubType: string read FContentSubType write SetContentSubType;
  end;

  TclAttachmentBody = class(TclMessageBody)
  private
    FContentID: string;
    FFileName: string;
    procedure AssignEncodingIfNeed;
    procedure SetContentID(const Value: string);
    function GetContentID(ASource, AFieldList: TStrings): string;
    function GetMessageRfc822FileName(ABodyPos: Integer; ASource: TStrings): string;
  protected
    procedure SetFileName(const Value: string); virtual;
    procedure ReadData(Reader: TReader); override;
    procedure WriteData(Writer: TWriter); override;
    function GetEncoding: TclEncodeMethod; override;
    procedure AssignBodyHeader(ASource: TStrings); override;
    procedure ParseBodyHeader(ABodyPos: Integer; ASource, AFieldList: TStrings); override;
    function GetSourceStream: TStream; override;
    function GetDestinationStream: TStream; override;
    procedure RegisterFields; override;
  public
    procedure Assign(Source: TPersistent); override;
    procedure Clear(); override;
    property FileName: string read FFileName write SetFileName;
    property ContentID: string read FContentID write SetContentID;
  end;

  TclImageBody = class(TclAttachmentBody)
  private
    function GetUniqueContentID(const AFileName: string): string;
    function GetFileType(const AFileName: string): string;
  protected
    procedure SetFileName(const Value: string); override;
    procedure AssignBodyHeader(ASource: TStrings); override;
    procedure ParseBodyHeader(ABodyPos: Integer; ASource, AFieldList: TStrings); override;
  public
    procedure Clear(); override;
  end;

  TclMessageBodies = class(TPersistent)
  private
    FOwner: TclMailMessage;
    FList: TList;
    function GetItem(Index: Integer): TclMessageBody;
    function GetCount: Integer;
    procedure Add(AItem: TclMessageBody);
  protected
    function GetMailMessage: TclMailMessage;
    procedure DefineProperties(Filer: TFiler); override;
    procedure ReadData(Reader: TReader); virtual;
    procedure WriteData(Writer: TWriter); virtual;
    function AddItem(AItemClass: TclMessageBodyClass): TclMessageBody;
  public
    constructor Create(AOwner: TclMailMessage);
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function AddText(const AText: string): TclTextBody;
    function AddHtml(const AText: string): TclTextBody;
    function AddMultipart: TclMultipartBody;
    function AddAttachment(const AFileName: string): TclAttachmentBody;
    function AddImage(const AFileName: string): TclImageBody;
    procedure Delete(Index: Integer);
    procedure Move(CurIndex, NewIndex: Integer);
    procedure Clear;
    property Items[Index: Integer]: TclMessageBody read GetItem; default;
    property Count: Integer read GetCount;
  end;

  TclMailMessage = class(TComponent)
  private
    FCharSet: string;
    FSubject: string;
    FPriority: TclMessagePriority;
    FDate: TDateTime;
    FBodies: TclMessageBodies;
    FBCCList: TStrings;
    FCCList: TStrings;
    FToList: TStrings;
    FFrom: string;
    FMessageFormat: TclMessageFormat;
    FBoundary: string;
    FEncoding: TclEncodeMethod;
    FUpdateCount: Integer;
    FDataStream: TMemoryStream;
    FIsParse: Boolean;
    FOnChanged: TNotifyEvent;
    FOnGetDataStream: TclGetBodyStreamEvent;
    FOnDataAdded: TclBodyDataAddedEvent;
    FOnEncodingProgress: TclBodyEncodingProgress;
    FContentType: string;
    FContentSubType: string;
    FHeaderSource: TStrings;
    FBodiesSource: TStrings;
    FMessageSource: TStrings;
    FIncludeRFC822Header: Boolean;
    FReplyTo: string;
    FMessageID: string;
    FExtraFields: TStrings;
    FNewsGroups: TStrings;
    FReferences: TStrings;
    FLinesFieldPos: Integer;
    FReadReceiptTo: string;
    FOnGetDataSourceStream: TclGetBodyStreamEvent;
    FContentDisposition: string;
    FKnownFields: TStrings;
    FMimeOLE: string;
    FRawHeader: TStrings;
    FCharsPerLine: Integer;
    FRawBodyStart: Integer;
    procedure InternalParseHeader(ASource: TStrings);
    function ParseBodyHeader(AStartFrom: Integer; ASource: TStrings): TclMessageBody;
    procedure AssignBodyHeader(ASource: TStrings; ABody: TclMessageBody);
    procedure AfterAddData(ABody: TclMessageBody; AEncodedLines: Integer);
    procedure GetBodyFromSource(const ASource: string);
    procedure AddBodyToSource(ASource: TStrings; ABody: TclMessageBody);
    procedure SetBCCList(const Value: TStrings);
    procedure SetBodies(const Value: TclMessageBodies);
    procedure SetCCList(const Value: TStrings);
    procedure SetToList(const Value: TStrings);
    procedure SetCharSet(const Value: string);
    procedure SetDate(const Value: TDateTime);
    procedure SetEncoding(const Value: TclEncodeMethod);
    procedure SetFrom(const Value: string);
    procedure SetMessageFormat(const Value: TclMessageFormat);
    procedure SetPriority(const Value: TclMessagePriority);
    procedure SetSubject(const Value: string);
    procedure SetContentType(const Value: string);
    procedure SetContentSubType(const Value: string);
    procedure DoOnListChanged(Sender: TObject);
    procedure BuildImages(ABodies: TclMessageBodies; const AText, AHtml: string; AImages: TStrings);
    function BuildAlternative(ABodies: TclMessageBodies; const AText,
      AHtml: string): string;
    procedure BuildAttachments(ABodies: TclMessageBodies;
      Attachments: TStrings);
    function GetHeaderSource: TStrings;
    function GetBodiesSource: TStrings;
    function GetMessageSource: TStrings;
    procedure SetHeaderSource(const Value: TStrings);
    procedure SetMessageSource(const Value: TStrings);
    procedure SetIncludeRFC822Header(const Value: Boolean);
    procedure SetCharsPerLine(const Value: Integer);
    function ParseDate(ASource, AFieldList: TStrings): TDateTime;
    procedure SetExtraFields(const Value: TStrings);
    procedure SetNewsGroups(const Value: TStrings);
    procedure SetReferences(const Value: TStrings);
    procedure SetReplyTo(const Value: string);
    function BuildDelimitedField(AValues: TStrings;
      const ADelimiter: string): string;
    procedure InternalGetBodyText(ABodies: TclMessageBodies; AStrings: TStrings);
    procedure SetReadReceiptTo(const Value: string);
    procedure SetMessageID(const Value: string);
    procedure SetContentDisposition(const Value: string);
    function IsUUEBodyStart(const ALine: string; var AFileName: string): Boolean;
    function IsUUEBodyEnd(const ALine: string): Boolean;
    procedure SetMimeOLE(const Value: string);
  protected
    procedure SafeClear;
    procedure SetBoundary(const Value: string);
    procedure ParseBodies(ASource: TStrings);
    function ParseAllHeaders(AStartFrom: Integer; ASource, AHeaders: TStrings): Integer;
    procedure ParseExtraFields(AHeader, AKnownFields, AExtraFields: TStrings);
    procedure InternalAssignBodies(ASource: TStrings);
    procedure InternalAssignHeader(ASource: TStrings);
    procedure GenerateBoundary;
    function CreateBody(ABodies: TclMessageBodies;
      const AContentType, ADisposition: string): TclMessageBody; virtual;
    function CreateSingleBody(ASource: TStrings; ABodies: TclMessageBodies): TclMessageBody; virtual;
    function CreateUUEAttachmentBody(ABodies: TclMessageBodies;
      const AFileName: string): TclAttachmentBody; virtual;
    procedure Changed; virtual;
    procedure DoGetDataStream(ABody: TclMessageBody;
      const AFileName: string; var AData: TStream; var Handled: Boolean); virtual;
    procedure DoGetDataSourceStream(ABody: TclMessageBody;
      const AFileName: string; var AData: TStream; var Handled: Boolean); virtual;
    procedure DoDataAdded(ABody: TclMessageBody; AData: TStream); virtual;
    procedure DoEncodingProgress(ABodyNo, ABytesProceed, ATotalBytes: Integer); virtual;
    procedure Loaded; override;
    procedure ParseContentType(ASource, AFieldList: TStrings); virtual;
    procedure AssignContentType(ASource: TStrings); virtual;
    function GetIsMultiPartContent: Boolean; virtual;
    procedure RegisterField(const AField: string);
    procedure RegisterFields; virtual;
    property KnownFields: TStrings read FKnownFields;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Clear; virtual;
    procedure Update;
    procedure BeginUpdate;
    procedure EndUpdate;
    procedure BuildMessage(const AText, AHtml: string; AImages, Attachments: TStrings); overload;
    procedure BuildMessage(const AText, AHtml: string; const AImages, Attachments: array of string); overload;
    procedure BuildMessage(const AText: string; Attachments: TStrings); overload;
    procedure BuildMessage(const AText: string; const Attachments: array of string); overload;
    procedure BuildMessage(const AText, AHtml: string); overload;
    procedure GetBodyText(AStrings: TStrings);
    property IsMultiPartContent: Boolean read GetIsMultiPartContent;
    property IsParse: Boolean read FIsParse;
    property Boundary: string read FBoundary;
    property HeaderSource: TStrings read GetHeaderSource write SetHeaderSource;
    property BodiesSource: TStrings read GetBodiesSource;
    property MessageSource: TStrings read GetMessageSource write SetMessageSource;
    property RawHeader: TStrings read FRawHeader;
    property RawBodyStart: Integer read FRawBodyStart;
  published
    property Bodies: TclMessageBodies read FBodies write SetBodies;
    property Subject: string read FSubject write SetSubject;
    property From: string read FFrom write SetFrom;
    property ToList: TStrings read FToList write SetToList;
    property CCList: TStrings read FCCList write SetCCList;
    property BCCList: TStrings read FBCCList write SetBCCList;
    property Priority: TclMessagePriority read FPriority write SetPriority default mpNormal;
    property Date: TDateTime read FDate write SetDate;
    property CharSet: string read FCharSet write SetCharSet;
    property ContentType: string read FContentType write SetContentType;
    property ContentSubType: string read FContentSubType write SetContentSubType;
    property ContentDisposition: string read FContentDisposition write SetContentDisposition;
    property MessageFormat: TclMessageFormat read FMessageFormat write SetMessageFormat default mfNone;
    property Encoding: TclEncodeMethod read FEncoding write SetEncoding default cmNone;
    property MimeOLE: string read FMimeOLE write SetMimeOLE;
    property IncludeRFC822Header: Boolean read FIncludeRFC822Header write SetIncludeRFC822Header default True;
    property ReplyTo: string read FReplyTo write SetReplyTo;
    property References: TStrings read FReferences write SetReferences;
    property NewsGroups: TStrings read FNewsGroups write SetNewsGroups;
    property ExtraFields: TStrings read FExtraFields write SetExtraFields;
    property ReadReceiptTo: string read FReadReceiptTo write SetReadReceiptTo;
    property MessageID: string read FMessageID write SetMessageID;
    property CharsPerLine: Integer read FCharsPerLine write SetCharsPerLine default DefaultCharsPerLine;

    property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
    property OnGetDataStream: TclGetBodyStreamEvent read FOnGetDataStream write FOnGetDataStream;
    property OnGetDataSourceStream: TclGetBodyStreamEvent read FOnGetDataSourceStream write FOnGetDataSourceStream;
    property OnDataAdded: TclBodyDataAddedEvent read FOnDataAdded write FOnDataAdded;
    property OnEncodingProgress: TclBodyEncodingProgress read FOnEncodingProgress write FOnEncodingProgress;
  end;

function EmailListToString(AEmailList: TStrings): string;
procedure StringToEmailList(const AEmails: string; AEmailList: TStrings);
function EncodeField(const AFieldValue, ACharSet: string; ADefaultEncoding: TclEncodeMethod;
  ACharsPerLine: Integer = DefaultCharsPerLine): string;
function DecodeField(const AFieldValue, ADefaultCharSet: string): string;
function EncodeEmail(const ACompleteEmail, ACharSet: string; ADefaultEncoding: TclEncodeMethod;
  ACharsPerLine: Integer = DefaultCharsPerLine): string;
function DecodeEmail(const ACompleteEmail, ADefaultCharSet: string): string;
procedure RegisterBody(AMessageBodyClass: TclMessageBodyClass);
function GetRegisteredBodyItems: TList;
function DateTimeToMailTime(ADateTime: TDateTime): string;
function MailTimeToDateTime(const ADateTimeStr: string): TDateTime;
function GetCompleteEmailAddress(const AName, AEmail: string): string;
function GetEmailAddressParts(const ACompleteEmail: string; var AName, AEmail: string): Boolean;

resourcestring
  cWrondEncodingMethod = 'Wrong encoding method in field';
  cMailAgent = 'Clever Internet Suite v 6.2';
  cMimeOLE = 'Produced By Clever Internet Suite MimeOLE v 6.2';

{$IFDEF DEMO}
{$IFNDEF IDEDEMO}
var
  IsMailMessageDemoDisplayed: Boolean = False;
{$ENDIF}
{$ENDIF}
  
implementation

uses
  Windows, clUtils, clTranslator
  {$IFDEF DEMO}, Forms{$ENDIF};

const
  cDefaultContentType = 'text/plain';
  cDefaultCharSet = 'iso-8859-1';
  ImportanceMap: array[TclMessagePriority] of string = ('Low', '', 'High');
  PiorityMap: array[TclMessagePriority] of string = ('5', '3', '1');
  MSPiorityMap: array[TclMessagePriority] of string = ('Low', 'Normal', 'High');
  EncodingMap: array[TclEncodeMethod] of string = ('7bit', 'quoted-printable', 'base64', '', '8bit');
  ContentTypeMap: array[Boolean] of TclMessageFormat = (mfUUencode, mfMIME);

var
  RegisteredBodyItems: TList = nil;