D6HECHUAN/信息提醒/USendStatus.pas

unit USendStatus;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, SmtpProt;

type
  TMailSendQueue = record
    Topic: string;
    Content: string;
    MailAddr: string;
    CCMailAddr: string;
    AttachFiles: string;
    SmtpMailName: string;
    SmtpServer: string;
    SmtpPort: string;
    SmtpUser: string;
    SmtpPass: string;
    TestMail: Boolean;
  end;

  TFrmSendStatus = class(TForm)
    lbl1: TLabel;
    mmo1: TMemo;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure CreateParams(var Params: TCreateParams); override;
  end;

  TSendMailThread = class(TThread)
  private
    Fsmtpcli: TSmtpCli;
    FLogInfo: string;
    FErrorFlag: Boolean;
    FSuccFlag: Boolean;
    FMailSendQueue: TMailSendQueue;

    procedure smtpcl1Command(Sender: TObject; Msg: string);
    procedure smtpcl1RequestDone(Sender: TObject; RqType: TSmtpRequest;
      ErrorCode: Word);
    procedure smtpcl1Response(Sender: TObject; Msg: string);
    procedure SynAddLog();
    procedure AddLog(LogInfo: string);
    procedure SynUpdateStatus();
    procedure UpdateStatus(LogInfo: string);
    procedure SynShowResult();
    procedure ShowResult(LogInfo: string);
  protected
    procedure Execute; override;
  public
    constructor Create(AMailSendQueue: TMailSendQueue);
  end;

var
  FrmSendStatus: TFrmSendStatus;

implementation



{$R *.dfm}

{ TSendMailThread }

procedure TSendMailThread.AddLog(LogInfo: string);
begin
  FLogInfo := LogInfo;
  Synchronize(SynAddLog);
end;

constructor TSendMailThread.Create(AMailSendQueue: TMailSendQueue);
begin
  inherited Create(true);
  FMailSendQueue := AMailSendQueue;
  Fsmtpcli := TSmtpCli.Create(Application);
  Fsmtpcli.Host := FMailSendQueue.SmtpServer;
  Fsmtpcli.Port := FMailSendQueue.SmtpPort;
  Fsmtpcli.SignOn := FMailSendQueue.SmtpUser;
  Fsmtpcli.FromName := FMailSendQueue.SmtpMailName;
  Fsmtpcli.HdrFrom := FMailSendQueue.SmtpMailName;
  Fsmtpcli.AuthType := smtpAuthAutoSelect;
  Fsmtpcli.Username := FMailSendQueue.SmtpUser;
  Fsmtpcli.Password := FMailSendQueue.SmtpPass;
  Fsmtpcli.HdrPriority := smtpPriorityNormal;
  Fsmtpcli.ConfirmReceipt := False;
  Fsmtpcli.OnCommand := smtpcl1Command;
  Fsmtpcli.OnResponse := smtpcl1Response;
  Fsmtpcli.OnRequestDone := smtpcl1RequestDone;
end;

procedure TSendMailThread.Execute;
var
  TT: Cardinal;
begin
  try
    FreeOnTerminate := True;
    Fsmtpcli.HdrTo := FMailSendQueue.MailAddr;
    Fsmtpcli.HdrCc := FMailSendQueue.CCMailAddr;
    Fsmtpcli.EmailFiles.Text := FMailSendQueue.AttachFiles;
    Fsmtpcli.HdrSubject := FMailSendQueue.Topic;
    Fsmtpcli.RcptName.Clear;
    Fsmtpcli.RcptNameAdd(FMailSendQueue.MailAddr, Fsmtpcli.HdrCc, '');
    Fsmtpcli.MailMessage.Text := FMailSendQueue.Content;
    FErrorFlag := False;
    FSuccFlag := False;
    try
//      AddLog('<27><><EFBFBD><EFBFBD>SMTP<54><50><EFBFBD><EFBFBD><EFBFBD><EFBFBD>(' + FMailSendQueue.SmtpServer + ')...');
      Fsmtpcli.Connect;
    except on e: Exception do
      begin
        FErrorFlag := True;
//        ShowResult('<27><><EFBFBD><EFBFBD>SMTP<54><50><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>,' + e.Message);
        Exit;
      end;
    end;
    TT := GetTickCount;
    while ((GetTickCount - TT) < 360000) and (not Terminated) do
    begin
      Application.ProcessMessages;
      Sleep(100);
      if FErrorFlag or FSuccFlag then
      begin
        Break;
      end;
    end;
    if FErrorFlag then
    begin
//      ShowResult('<27><><EFBFBD><EFBFBD><EFBFBD>ʼ<EFBFBD><CABC><EFBFBD><EFBFBD><EFBFBD>(' + Fsmtpcli.ErrorMessage + ')<29><>');
    end
    else
      if FSuccFlag then
      begin
        if FMailSendQueue.TestMail then
//          ShowResult('<27><><EFBFBD><EFBFBD><EFBFBD>ʼ<EFBFBD><CABC>ɹ<EFBFBD>(TO:' + FMailSendQueue.MailAddr + ')')
        else
        begin
//          DeleteFile(FMailSendQueue.AttachFiles);
        end;
      end;
  finally
    begin
      if Fsmtpcli.Connected then
        Fsmtpcli.Quit;
      Fsmtpcli.Destroy;
      FrmSendStatus.Close;
//      if FMailSendQueue.TestMail then
//        FrmSendStatus.Close
//      else
//      begin
//        FrmSendStatus.Close;
//      end;
    end;
  end;
end;

procedure TSendMailThread.ShowResult(LogInfo: string);
begin
  FLogInfo := LogInfo;
  Synchronize(SynShowResult);
end;

procedure TSendMailThread.smtpcl1Command(Sender: TObject; Msg: string);
begin
end;

procedure TSendMailThread.smtpcl1RequestDone(Sender: TObject;
  RqType: TSmtpRequest; ErrorCode: Word);
begin
  { For every operation, we display the status }
//  if (ErrorCode > 0) and (ErrorCode < 10000) then
//    AddLog('RequestDone Rq=' + IntToStr(Ord(RqType)) +
//      ' Error=' + Fsmtpcli.ErrorMessage)
//  else
//    AddLog('RequestDone Rq=' + IntToStr(Ord(RqType)) +
//      ' Error=' + IntToStr(ErrorCode));
  if ErrorCode <> 0 then begin
    FErrorFlag := True;
    Exit;
  end;
  case RqType of
    smtpConnect: begin
        if Fsmtpcli.AuthType = smtpAuthNone then
          Fsmtpcli.Helo
        else
          Fsmtpcli.Ehlo;
      end;
    smtpHelo: Fsmtpcli.MailFrom;
    smtpEhlo: Fsmtpcli.Auth;
    smtpAuth: Fsmtpcli.MailFrom;
    smtpMailFrom: Fsmtpcli.RcptTo;
    smtpRcptTo: Fsmtpcli.Data;
    smtpData: Fsmtpcli.Quit;
    smtpQuit:
      begin
        if not FErrorFlag then
          FSuccFlag := True;
      end;
  end;
end;

procedure TSendMailThread.smtpcl1Response(Sender: TObject; Msg: string);
begin
end;

procedure TSendMailThread.SynAddLog;
begin

end;

procedure TSendMailThread.SynShowResult;
begin
  if FErrorFlag then
    MessageBox(FrmSendStatus.Handle, PChar(FLogInfo), '<27><><EFBFBD><EFBFBD>', MB_OK or MB_ICONERROR)
  else
    MessageBox(FrmSendStatus.Handle, PChar(FLogInfo), '<27><>ʾ', MB_OK or MB_ICONINFORMATION);
end;

procedure TSendMailThread.SynUpdateStatus;
begin
  FrmSendStatus.lbl1.Caption := FLogInfo;
  FrmSendStatus.lbl1.Update;
end;

procedure TSendMailThread.UpdateStatus(LogInfo: string);
begin
  FLogInfo := LogInfo;
  Synchronize(SynUpdateStatus);
end;

procedure TFrmSendStatus.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    exStyle := exStyle or WS_EX_APPWINDOW;
end;

procedure TFrmSendStatus.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;

end.