frxsmtp.pas

这个是功能强大的报表软件

{******************************************}
{                                          }
{              FastReport 4.0              }
{        SMTP connection client unit       }
{                                          }
{         Copyright (c) 2006-2008          }
{         by Alexander Fediachov,          }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxSMTP;

interface

{$I frx.inc}

uses
  Windows, SysUtils, Classes, ScktComp, frxNetUtils, frxUtils, frxProgress
{$IFDEF Delphi6}, Variants {$ENDIF}, frxMD5, frxUnicodeUtils;


type
  TfrxSMTPClientThread = class;

  TfrxSMTPClient = class(TComponent)
  private
    FActive: Boolean;
    FBreaked: Boolean;
    FErrors: TStrings;
    FHost: String;
    FPort: Integer;
    FThread: TfrxSMTPClientThread;
    FTimeOut: Integer;
    FPassword: String;
    FMailTo: WideString;
    FUser: String;
    FMailFiles: TStringList;
    FMailFrom: WideString;
    FMailSubject: WideString;
    FMailText: WideString;
    FAnswer: AnsiString;
    FAccepted: Boolean;
    FAuth: String;
    FCode: Integer;
    FSending: Boolean;
    FProgress: TfrxProgress;
    FShowProgress: Boolean;
    FLogFile: String;
    FLog: TStringList;
    FAnswerList: TStringList;
    F200Flag: Boolean;
    F210Flag: Boolean;
    F215Flag: Boolean;
    FOrganization: WideString;
    FMailCc: WideString;
    FMailBcc: WideString;
    FRcptList: TStringList;
    procedure DoConnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure DoDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure DoError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure DoRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SetActive(const Value: Boolean);
    procedure AddLogIn(const s: String);
    procedure AddLogOut(const s: String);
    function DomainByEmail(const addr: String): String;
    function UnicodeField(const Str: WideString): AnsiString;
    function UnicodeString(const Str: WideString): AnsiString;
    function GetEmailAddress(const Str: String): String;
    procedure PrepareRcpt;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Connect;
    procedure Disconnect;
    procedure Open;
    procedure Close;
    property Breaked: Boolean read FBreaked;
    property Errors: TStrings read FErrors write Ferrors;
    property LogFile: String read FLogFile write FLogFile;
  published
    property Active: Boolean read FActive write SetActive;
    property Host: String read FHost write FHost;
    property Port: Integer read FPort write FPort;
    property TimeOut: Integer read FTimeOut write FTimeOut;
    property User: String read FUser write FUser;
    property Password: String read FPassword write FPassword;
    property MailFrom: WideString read FMailFrom write FMailFrom;
    property MailTo: WideString read FMailTo write FMailTo;
    property MailCc: WideString read FMailCc write FMailCc;
    property MailBcc: WideString read FMailBcc write FMailBcc;
    property MailSubject: WideString read FMailSubject write FMailSubject;
    property MailText: WideString read FMailText write FMailText;
    property MailFiles: TStringList read FMailFiles write FMailFiles;
    property ShowProgress: Boolean read FShowProgress write FShowProgress;
    property Organization: WideString read FOrganization write FOrganization;
  end;

  TfrxSMTPClientThread = class (TThread)
  protected
    FClient: TfrxSMTPClient;
    procedure DoOpen;
    procedure Execute; override;
  public
    FSocket: TClientSocket;
    constructor Create(Client: TfrxSMTPClient);
    destructor Destroy; override;
  end;

implementation

uses frxRes, frxrcExports{$IFDEF Delphi7}, StrUtils{$ENDIF};

const
  MIME_STRING_SIZE = 57;
  boundary = '----------';

type
  THackThread = class(TThread);


{ TfrxSMTPClient }

constructor TfrxSMTPClient.Create(AOwner: TComponent);
begin
  inherited;
  FErrors := TStringList.Create;
  FHost := '127.0.0.1';
  FPort := 25;
  FActive := False;
  FTimeOut := 60;
  FBreaked := False;
  FThread := TfrxSMTPClientThread.Create(Self);
  FThread.FSocket.OnConnect := DoConnect;
  FThread.FSocket.OnRead := DoRead;
  FThread.FSocket.OnDisconnect := DoDisconnect;
  FThread.FSocket.OnError := DoError;
  FShowProgress := False;
  FLogFile := '';
  FLog := TStringList.Create;
  FAnswerList := TStringList.Create;
  FMailFiles := TStringList.Create;
  FRcptList := TStringList.Create;
end;

destructor TfrxSMTPClient.Destroy;
begin
  FRcptList.Free;
  FMailFiles.Free;
  Close;
  while FActive do
    Sleep(1);
//    PMessages;
  FThread.Free;
  FErrors.Free;
  FLog.Free;
  FAnswerList.Free;
  inherited;
end;

procedure TfrxSMTPClient.Connect;
var
  ticks: Cardinal;
begin
  FLog.Clear;
  if (FLogFile <> '') and FileExists(LogFile) then
    FLog.LoadFromFile(LogFile);
  FLog.Add(DateTimeToStr(Now));
  FErrors.Clear;
  FActive := True;
  FThread.FSocket.Host := FHost;
  FThread.FSocket.Address := FHost;
  FThread.FSocket.Port := FPort;
  FThread.FSocket.ClientType := ctNonBlocking;
  F200Flag := False;
  F210Flag := False;
  F215Flag := False;
  if FShowProgress then
  begin
    FProgress := TfrxProgress.Create(Self);
    FProgress.Execute(100, frxGet(8924) + ' ' + FMailTo, False, True);
  end;
  FThread.Execute;
  try
    ticks := GetTickCount;
    while FActive and (not FBreaked) do
    begin
//      PMessages;
      if FShowProgress then
        FProgress.Tick;
      if ((GetTickCount - ticks) > Cardinal(FTimeOut * 1000)) then
      begin
        Errors.Add('Timeout expired (' + IntToStr(FTimeOut) + ')');
        break;
      end;
      if FSending then
        ticks := GetTickCount;
      Sleep(100);
    end;
  finally
    if FShowProgress then
      FProgress.Free;
    Disconnect;
  end;
  FLog.Add('---' + DateTimeToStr(Now));
  FLog.AddStrings(FErrors);
  if FLogFile <> '' then
    FLog.SaveToFile(FLogFile);
end;

procedure TfrxSMTPClient.Disconnect;
begin
  FThread.FSocket.Close;
  FThread.Terminate;
  FActive := False;
end;

procedure TfrxSMTPClient.DoConnect(Sender: TObject;
  Socket: TCustomWinSocket);
var
  s: String;
begin
  PrepareRcpt;
  s := 'HELO ' + DomainByEmail(FMailFrom) + #13#10;
  Socket.SendText(AnsiString(s));
  AddLogOut(s);
  FCode := 0;
  FAuth := FUser;
  FAccepted := False;
  FSending := False;
end;

procedure TfrxSMTPClient.DoDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  if Pos(AnsiString('221'), FAnswer) = 0 then
    Errors.Add(String(FAnswer));
  FActive := False;
  FSending := False;
end;

procedure TfrxSMTPClient.DoError(Sender: TObject; Socket: TCustomWinSocket;
  ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
  if FAnswer <> '' then
    Errors.Add(String(FAnswer));
  Errors.Add(GetSocketErrorText(ErrorCode));
  FActive := False;
  ErrorCode := 0;
  FSending := False;
end;

procedure TfrxSMTPClient.DoRead(Sender: TObject; Socket: TCustomWinSocket);
var
  buf: PAnsiChar;
  i, j, k: Integer;
  Stream: TMemoryStream;
  fbuf: PAnsiChar;
  FStream: TFileStream;
  s, s1, s2: String;
{$IFDEF Delphi12}
  s1a, sa: AnsiString;
{$ENDIF}
  bound: String;

  procedure OutStream(const S: String);{$IFDEF Delphi12} overload;{$ENDIF}
{$IFDEF Delphi12}
  var
    TempStr: AnsiString;
{$ENDIF}
  begin
{$IFDEF Delphi12}
    TempStr := AnsiString(S);
    Stream.Write(TempStr[1], Length(TempStr));
    Stream.Write(AnsiString(#13#10), 2);
{$ELSE}
    Stream.Write(S[1], Length(S));
    Stream.Write(#13#10, 2);
{$ENDIF}
{$IFDEF FR_DEBUG}
    FLog.Add(s);
{$ENDIF}
  end;

{$IFDEF Delphi12}
  procedure OutStream(const S: AnsiString); overload;
  begin
    Stream.Write(S[1], Length(S));
    Stream.Write(AnsiString(#13#10), 2);
{$IFDEF FR_DEBUG}
    FLog.Add(s);
{$ENDIF}
  end;
{$ENDIF}

begin
  i := Socket.ReceiveLength;
  GetMem(buf, i);
  try
    try
      i := Socket.ReceiveBuf(buf^, i);
      SetLength(FAnswer, i);
      CopyMemory(PAnsiChar(FAnswer), buf, i);
       FAnswerList.Text := String(FAnswer);

      for k := 0 to FAnswerList.Count - 1 do
      begin
        FAnswer := AnsiString(FAnswerList[k]);
        FCode := StrToInt(Copy(String(FAnswer), 1, 3));
        AddLogIn(String(FAnswer));
        if (FCode = 235) then
        begin
          FCode := 220;
          FAccepted := True;
        end;
        if (FUser <> '') and (not FAccepted) and (FCode = 220) then