nmsmtp.pas

DELPHI里面一些常用的控件

unit NMsmtp;
{$X+}
{$R-}

{$IFDEF VER100}
{$DEFINE NMF3}
{$ENDIF}
{$IFDEF VER110}
{$DEFINE NMF3}
{$ENDIF}
{$IFDEF VER120}
{$DEFINE NMF3}
{$ENDIF}
{$IFDEF VER125}
{$DEFINE NMF3}
{$ENDIF}

interface

uses
  Classes, PSock, sysutils, NMuue, NMExtstr, NMConst;
{$IFDEF VER110}
{$OBJEXPORTALL On}
{$ENDIF}
{$IFDEF VER120}
{$OBJEXPORTALL On}
{$ENDIF}
{$IFDEF VER125}
{$OBJEXPORTALL On}
{$ENDIF}

const


  SMTP_PORT = 25;

  //  CompName     ='TNMSMTP';
  //  Major_Version='4';
  //  Minor_Version='03';
  //  Date_Version ='020398';

  CRLF = #13#10;

  hiFromAddress = 1;
  hiToAddress = 2;

const {protocol}
  Cons_Helo = 'HELO ';
  Cons_Quit = 'QUIT';
  Cons_Rset = 'RSET';
  Cons_From = 'MAIL FROM:<';
  Cons_To = 'RCPT TO:<';
  Cons_Date = 'DATA';
  Cons_Expn = 'EXPN ';
  Cons_Vrfy = 'VRFY ';
  Cons_Head_subj = 'Subject';
  Cons_Head_from = 'From: ';
  Cons_Head_To = 'To: ';
  Cons_Head_CC = 'CC: ';
  Cons_Head_mail = 'X-Mailer';
  Cons_Head_ReplyTo = 'Reply-To';
  Cons_Head_Date = 'Date';
  Cons_Head_mime = 'Mime-Version: 1.0';
  Cons_Head_disp = 'Content-Disposition: attachment; filename="';
  Cons_Head_ba64 = 'Content-Transfer-Encoding: base64';
  Cons_Head_appl = 'Content-Type: application/octet-stream; name="';
  Cons_Head_text = 'Content-Type: text/plain; charset=';
  Cons_Head_Enriched = 'Content-Type: text/enriched; charset=';
  Cons_Head_Sgml = 'Content-Type: text/sgml; charset=';
  Cons_Head_TabSeperated = 'Content-Type: text/tab-separated-values; charset=';
  Cons_Head_mtHtml = 'Content-Type: text/html; charset=';
  // Cons_Head_text2       = 'Content-Type: text/plain, charset="iso-8859-1"';
  Cons_Head_mult = 'Content-Type: multipart/mixed; boundary="';
  Cons_Head_7Bit = 'Content-Transfer-Encoding: 7Bit';

type
  TSubType = (mtPlain, mtEnriched, mtSgml, mtTabSeperated, mtHtml);

  THeaderInComplete = procedure(var handled: boolean; hiType: integer) of object;
  TRecipientNotFound = procedure(Recipient: string) of object;
  TMailListReturn = procedure(MailAddress: string) of object;
  TFileItem = procedure(Filename: string) of object;

  TPostMessage = class(TPersistent)
  private

    FFromName, FFrom, FSubject, FLocalProgram, FDate, FReplyTo: string;
    FAttachments, FTo, FCC, FBCC: TStringList;
    FBody: TStringList;
  protected
    procedure SetLinesTo(Value: TStringList);
    procedure SetLinesCC(Value: TStringList);
    procedure SetLinesBCC(Value: TStringList);
    procedure SetLinesBody(Value: TStringList);
    procedure SetLinesAttachments(Value: TStringList);
  public
    constructor Create;
    destructor Destroy; override;

  published

    property FromAddress: string read FFrom write FFrom;
    property FromName: string read FFromName write FFromName;
    property ToAddress: TStringList read FTo write SetLinesTo;
    property ToCarbonCopy: TStringList read FCC write SetLinesCC;
    property ToBlindCarbonCopy: TStringList read FBCC write SetLinesBCC;
    property Body: TStringList read FBody write SetLinesBody;
    property Attachments: TStringList read FAttachments write SetLinesAttachments;
    property Subject: string read FSubject write FSubject;
    property LocalProgram: string read FLocalProgram write FLocalProgram;
    property Date: string read FDate write FDate;
    property ReplyTo: string read FReplyTo write FReplyTo;
  end;

  TNMSMTP = class(TPowerSock)
  private
    FCharset: string;
    FOnConnect: TNotifyEvent;
    FPostMessage: TPostMessage;
    FsenFmem: TMemoryStream;
    (*{$IFDEF NMF3}
          FSendFile: TS_BufferStream;
    {$ELSE}   *)
    FSendFile: TMemoryStream;
    //{$ENDIF}
    FFinalHeader: TExStringList;
    FTransactionInProgress, FAbort: boolean;
    FUserID, FBoundary: string;
    FSubType: TSubType;
    FOnHeaderInComplete: THeaderInComplete;
    FOnSendStart, FOnSuccess, FOnFailure: TNotifyEvent;
    FOnEncodeStart, FOnEncodeEnd: TFileItem;
    FOnAttachmentNotFound: TFileItem;
    FRecipientNotFound {,FMessageSent}: TRecipientNotFound;
    FMailListReturn: TMailListReturn;
    FOnAuthenticationFailed: THandlerEvent;
    fUUMethod: UUMethods;
    FClearParams: boolean;
    WaitForReset: integer;
{$IFDEF NMDEMO}
    DemoStamped: boolean;
{$ENDIF}
    procedure ReadExtraLines(var ReplyMess: string);
    procedure SendAttachments(i: integer);
    procedure AssembleMail;
    procedure AbortResume(Sender: TObject);
    procedure SetFinalHeader(Value: TExStringList);
    //function CreateTemporaryFileName: string;
  protected

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Connect; override;
    procedure Disconnect; override;
    procedure SendMail;
    procedure Abort; override;
    procedure ClearParameters;
    function ExtractAddress(TotalAddress: string): string;
    function Verify(UserName: string): boolean;
    function ExpandList(MailList: string): boolean;
  published
    property OnPacketSent;
    property OnConnectionRequired;
    property OnConnect: TNotifyEvent read FOnConnect write FOnConnect;
    property UserID: string read FUserID write FUserID;
    property PostMessage: TPostMessage read FPostMessage write FPostMessage;
    property FinalHeader: TExStringList read FFinalHeader write SetFinalHeader;
    property EncodeType: UUMethods read fUUMethod write fUUMethod;
    property ClearParams: boolean read FClearParams write FClearParams;
    property SubType: TSubType read FSubType write FSubType;
    property Charset: string read FCharset write FCharset;
    property OnRecipientNotFound: TRecipientNotFound read FRecipientNotFound write FRecipientNotFound;
    property OnHeaderIncomplete: THeaderInComplete read FOnHeaderInComplete write FOnHeaderInComplete;
    property OnSendStart: TNotifyEvent read FOnSendStart write FOnSendStart;
    property OnSuccess: TNotifyEvent read FOnSuccess write FOnSuccess;
    property OnFailure: TNotifyEvent read FOnFailure write FOnFailure;
    property OnEncodeStart: TFileItem read FOnEncodeStart write FOnEncodeStart;
    property OnEncodeEnd: TFileItem read FOnEncodeEnd write FOnEncodeEnd;
    property OnMailListReturn: TMailListReturn read FMailListReturn write FMailListReturn;
    property OnAttachmentNotFound: TFileItem read FOnAttachmentNotFound write FOnAttachmentNotFound;
    property OnAuthenticationFailed: THandlerEvent read FOnAuthenticationFailed write FOnAuthenticationFailed;
  end;

implementation
uses
  Windows;

var
  mailcount: integer;

function StripCRLF(InStr: string): string;
begin
  if InStr <> '' then
    if InStr[Length(InStr)] = #10 then
      Result := Copy(InStr, 1, Length(InStr) - 2)
    else Result := InStr;
end;

{*******************************************************************************************
Constructor - Create String Lists to hold body, attachment list and distribution lists.
Sets Default port and clears Transaction in Progress flag.
********************************************************************************************}

constructor TNMSMTP.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  try
    Port := SMTP_PORT;
    EncodeType := UUMime;
    FTransactionInProgress := FALSE;
    FPostMessage := TPostMessage.Create;
    FFinalHeader := TExStringList.Create;
    FsenFmem := TMemoryStream.Create;
    (*{$IfDef NMF3}
        FSendFile := TS_BufferStream.create(FsenFmem);
    {$ELSE}  *)
    FSendFile := TMemoryStream.Create;
    // {$ENDIF}
    FClearParams := TRUE;
    FSubType := mtPlain;
    FCharset := 'GB2312';
    OnAbortRestart := AbortResume;
    WaitForReset := 2;
  except
    Destroy;
  end;
end;

{*******************************************************************************************
Constructor - Destroys String Lists holding body, attachment list and distribution lists.
********************************************************************************************}

destructor TNMSMTP.Destroy;
begin
  if FPostMessage <> nil then
    FPostMessage.free;
  FFinalHeader.free;
  FSendFile.free;
  FsenFmem.free;
  inherited Destroy;
end;

{*******************************************************************************************
Connect - Calls inherited socket connect and gets reply. Sends Greeting to server
and gets reply.
********************************************************************************************}

procedure TNMSMTP.Connect;
var
  ReplyMess: string;
  TryCt: integer;
  ConnCalled, handled: boolean;
  Done: boolean;
begin
  ConnCalled := FALSE;
  Done := FALSE;
  if FTransactionInProgress then
    ConnCalled := TRUE
  else
    FTransactionInProgress := TRUE;
  try
    inherited Connect;
    try
      ReplyMess := Readln;
      ReadExtraLines(ReplyMess);
      if ReplyNumber > 399 then
        raise Exception.Create(ReplyMess);
      TryCt := 0;
      repeat
        ReplyMess := Transaction(Cons_Helo + FUserID);
        ReadExtraLines(ReplyMess);
        if ReplyNumber > 299 then
          if TryCt > 0 then
            raise Exception.Create(Cons_Msg_Auth_Fail)
          else if not Assigned(FOnAuthenticationFailed) then
            raise Exception.Create(Cons_Msg_Auth_Fail)
          else
          begin
            handled := FALSE;
            FOnAuthenticationFailed(handled);
            if not handled then
              raise Exception.Create(Cons_Msg_Auth_Fail);
            TryCt := TryCt + 1;
          end;
      until ReplyNumber < 299;
      Done := TRUE;
    except
      Disconnect;
      raise
    end;
  finally
    if not ConnCalled then
      FTransactionInProgress := FALSE;
    if Done then
      if Assigned(FOnConnect) then
        FOnConnect(self);
  end;
end;

{*******************************************************************************************
Disconnect - Sends Quit message to server and gets Reply. Calls inherited disconnect to
close socket.
********************************************************************************************}

procedure TNMSMTP.Disconnect;
var ReplyMess: string;
begin
  Beencanceled := FALSE;
  try
    ReplyMess := Transaction(Cons_Quit);
    if ReplyNumber > 339 then
      raise Exception.Create(ReplyMess);
  finally
    inherited Disconnect;
  end;
end;

{*******************************************************************************************
SendMail - Posts a mail message to the server
********************************************************************************************}

procedure TNMSMTP.SendMail;
var
  ReplyMess: string;
  i, TryCt: integer;
  Done, handled: boolean;
  TAdd: string;
begin
  if not FTransactionInProgress then
  begin
    Done := FALSE;
    FTransactionInProgress := TRUE;
    try
      AssembleMail;
      CertifyConnect;
      TryCt := 0;
      repeat
        if (FPostMessage.FFrom = '') or ((FPostMessage.FTo.count = 0) and (FPostMessage.FCC.count = 0) and (FPostMessage.FBCC.count = 0)) then
          if TryCt > 0 then
            raise Exception.Create(sSMTP_Msg_Incomp_Head)
          else if not Assigned(FOnHeaderInComplete) then
            raise Exception.Create(sSMTP_Msg_Incomp_Head)
          else
          begin
            handled := FALSE;
            if FPostMessage.FFrom = '' then
              FOnHeaderInComplete(handled, hiFromAddress)
            else
              FOnHeaderInComplete(handled, hiToAddress);
            if not handled then
              raise Exception.Create(sSMTP_Msg_Incomp_Head);
            TryCt := TryCt + 1;
          end;
      until (FPostMessage.FFrom <> '') and ((FPostMessage.FTo.count <> 0) or (FPostMessage.FCC.count <> 0) or (FPostMessage.FBCC.count <> 0));
      if Assigned(FOnSendStart) then
        FOnSendStart(self);
      FAbort := FALSE;
      ReplyMess := Transaction(Cons_Rset);
      if ReplyNumber > 399 then
        raise Exception.Create(ReplyMess);
      if not FAbort then
        ReplyMess := Transaction(Cons_From + FPostMessage.FFrom + '>');
      if ReplyNumber > 399 then
        raise Exception.Create(ReplyMess);
      if not FAbort then
        for i := 1 to FPostMessage.FTo.count do
        begin
          TAdd := ExtractAddress(StripCRLF(FPostMessage.FTo.strings[i - 1]));
          if TAdd <> '' then
          begin
            ReplyMess := Transaction(Cons_To + TAdd + '>');
            if ReplyNumber > 300 then
              if Assigned(FRecipientNotFound) then
                FRecipientNotFound(FPostMessage.FTo.strings[i - 1]);
          end;
        end;
      if not FAbort then
        for i := 1 to FPostMessage.FCC.count do
        begin
          TAdd := ExtractAddress(StripCRLF(FPostMessage.FCC.strings[i - 1]));
          if TAdd <> '' then
          begin
            ReplyMess := Transaction(Cons_To + TAdd + '>');
            if ReplyNumber > 300 then
              if Assigned(FRecipientNotFound) then
                FRecipientNotFound(FPostMessage.FTo.strings[i - 1]);
          end;
        end;
      if not FAbort then
        for i := 1 to FPostMessage.FBCC.count do
        begin
          TAdd := ExtractAddress(FPostMessage.FBCC.strings[i - 1]);
          if TAdd <> '' then
          begin
            ReplyMess := Transaction(Cons_To + TAdd + '>');
            if ReplyNumber > 300 then
              if Assigned(FRecipientNotFound) then
                FRecipientNotFound(FPostMessage.FTo.strings[i - 1]);
          end;
        end;