usendstatus.~pas

由于工作需要

{*******************************************************}
{                                                       }
{       邮件备份代码工具                                }
{                                                       }
{       版权所有 (C) 2008                               }
{                                                       }
{       郑志强 [e-mail]                            }
{*******************************************************}

unit USendStatus;

interface

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

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

uses UMain;

{$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('连接SMTP服务器(' + FMailSendQueue.SmtpServer + ')...');
      Fsmtpcli.Connect;
    except on e: Exception do
      begin
        FErrorFlag := True;
        ShowResult('连接SMTP服务器出错,' + 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('发送邮件出错(' + Fsmtpcli.ErrorMessage + ')！');
    end
    else
      if FSuccFlag then
      begin
        if FMailSendQueue.TestMail then
          ShowResult('发送邮件成功(TO:' + FMailSendQueue.MailAddr + ')')
        else
        begin
          ShowResult('发送邮件成功(TO:' + FMailSendQueue.MailAddr + ')，' + #13#10 + '自动删除文件(' +
            FMailSendQueue.AttachFiles +
            ')！');
          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
  UpdateStatus('发送邮件状态：' + Msg);
  AddLog('>' + msg);
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
  AddLog('<' + msg);
end;

procedure TSendMailThread.SynAddLog;
var
  logfile: TextFile;
begin
  FrmSendStatus.mmo1.Lines.Add(FormatDateTime('hh:nn:ss', Now) + ' ' + FLogInfo);
  FrmSendStatus.mmo1.Update;
  if DebugMode then
  begin
    try
      if not DirectoryExists(Extractfilepath(Application.ExeName) + '\Log') then
      begin
        if not createdir(Extractfilepath(Application.ExeName) + '\Log') then
          exit;
      end;
      AssignFile(logfile, Extractfilepath(Application.ExeName) + '\Log\' + formatDatetime('yyyymmdd', now) +
        '.log');
      if not FileExists(Extractfilepath(Application.ExeName) + '\Log\' + formatDatetime('yyyymmdd', now) + '.log') then
        Rewrite(logfile)
      else
        reset(logfile);
      append(logfile);
      Writeln(logfile, DateTimeToStr(Now) + ':' + FLogInfo);
      closefile(logfile);
    except
      exit;
    end;
  end;
end;

procedure TSendMailThread.SynShowResult;
begin
  if FErrorFlag then
    MessageBox(FrmSendStatus.Handle, PChar(FLogInfo), '错误', MB_OK or MB_ICONERROR)
  else
    MessageBox(FrmSendStatus.Handle, PChar(FLogInfo), '提示', 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.