demoform.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

unit DemoForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, MyMail;

type
  TMainForm = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    TabSheet3: TTabSheet;
    PageControl2: TPageControl;
    TabSheet4: TTabSheet;
    TabSheet5: TTabSheet;
    Label7: TLabel;
    eFromName: TEdit;
    Label8: TLabel;
    eFromAddress: TEdit;
    Label10: TLabel;
    eReplyName: TEdit;
    Label11: TLabel;
    eReplyAddress: TEdit;
    TabSheet6: TTabSheet;
    mTextHtml: TMemo;
    Label6: TLabel;
    lbFiles: TListBox;
    bSave: TButton;
    bAttach: TButton;
    Label5: TLabel;
    bHtml: TButton;
    Label9: TLabel;
    mTextPlain: TMemo;
    bPlain: TButton;
    Label12: TLabel;
    eSubject: TEdit;
    Label13: TLabel;
    dtDate: TDateTimePicker;
    dtTime: TDateTimePicker;
    Label14: TLabel;
    mToNames: TMemo;
    Label15: TLabel;
    Label16: TLabel;
    mToAddresses: TMemo;
    Label17: TLabel;
    Label18: TLabel;
    mCcNames: TMemo;
    mCcAddresses: TMemo;
    bSaveHeader: TButton;
    OpenDialog: TOpenDialog;
    SaveDialog: TSaveDialog;
    bRemove: TButton;
    bPlainRemove: TButton;
    bHtmlRemove: TButton;
    MsgStatus: TLabel;
    GroupBox1: TGroupBox;
    Label23: TLabel;
    Label27: TLabel;
    eSmtpHost: TEdit;
    bSmtpConnect: TButton;
    bSmtpDisconnect: TButton;
    bSend: TButton;
    ProgressBar3: TProgressBar;
    eSmtpPort: TEdit;
    GroupBox2: TGroupBox;
    mSmtpResponse: TListBox;
    GroupBox3: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    lStatus: TLabel;
    Label26: TLabel;
    bConnect: TButton;
    eHost: TEdit;
    eUsername: TEdit;
    ePassword: TEdit;
    bDisconnect: TButton;
    bRetrieve: TButton;
    eMsgNum: TEdit;
    UpDown1: TUpDown;
    ProgressBar1: TProgressBar;
    ProgressBar2: TProgressBar;
    ePort: TEdit;
    GroupBox4: TGroupBox;
    mResponse: TListBox;
    GroupBox5: TGroupBox;
    mHeader: TMemo;
    Label19: TLabel;
    Label22: TLabel;
    mBody: TMemo;
    GroupBox6: TGroupBox;
    Label20: TLabel;
    Label21: TLabel;
    eLabel: TEdit;
    eValue: TEdit;
    bLabel: TButton;
    bDelLabel: TButton;
    bRebuild: TButton;
    bReset: TButton;
    bRefresh: TButton;
    bSaveMsg: TButton;
    bLoadMsg: TButton;
    POP: myTPOP;
    SMTP: myTSMTP;
    Msg: myTMailMessage;
    procedure bConnectClick(Sender: TObject);
    procedure bDisconnectClick(Sender: TObject);
    procedure bRetrieveClick(Sender: TObject);
    procedure bRefreshClick(Sender: TObject);
    procedure bRebuildClick(Sender: TObject);
    procedure bResetClick(Sender: TObject);
    procedure bLabelClick(Sender: TObject);
    procedure bDelLabelClick(Sender: TObject);
    procedure bSaveHeaderClick(Sender: TObject);
    procedure bSaveClick(Sender: TObject);
    procedure bAttachClick(Sender: TObject);
    procedure bPlainClick(Sender: TObject);
    procedure bHtmlClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure bSaveMsgClick(Sender: TObject);
    procedure bSmtpConnectClick(Sender: TObject);
    procedure bSmtpDisconnectClick(Sender: TObject);
    procedure bSendClick(Sender: TObject);
    procedure bLoadMsgClick(Sender: TObject);
    procedure bRemoveClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure POPProgress(Sender: TObject; Total, Current: Integer);
    procedure MsgProgress(Sender: TObject; Total, Current: Integer);
    procedure SMTPProgress(Sender: TObject; Total, Current: Integer);
    procedure bPlainRemoveClick(Sender: TObject);
    procedure bHtmlRemoveClick(Sender: TObject);
  end;

var
  MainForm: TMainForm;

implementation

{$R *.DFM}

procedure TMainForm.bConnectClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    POP.UserName := eUserName.Text;
    POP.Password := ePassword.Text;
    POP.Host := eHost.Text;
    POP.Port := StrToInt(ePort.Text);
    if POP.Connect then
    begin
        if POP.Login then
        begin
            lStatus.Caption :='信箱有 '+ IntToStr(POP.SessionMessageCount)+' 封信件';
            mResponse.Items.Text := POP.LastResponse;
            bDisconnect.Enabled := True;
            bRetrieve.Enabled := True;
            Screen.Cursor := crDefault;
        end
        else
        begin
            Screen.Cursor := crDefault;
            ShowMessage('Failed on login');
        end;
    end
    else
    begin
        Screen.Cursor := crDefault;
        ShowMessage('Failed on connect');
    end;
end;

procedure TMainForm.bDisconnectClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    if POP.Quit then
    begin
        lStatus.Caption := '状态：服务器断开';
        mResponse.Items.Text := POP.LastResponse;
        bDisconnect.Enabled := False;
        bRetrieve.Enabled := False;
        Screen.Cursor := crDefault;
    end
    else
    begin
        Screen.Cursor := crDefault;
        ShowMessage('Failed on quit');
    end;
end;

procedure TMainForm.bRetrieveClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    ProgressBar1.Position := 0;
    ProgressBar2.Position := 0;
    if POP.RetrieveMessage(StrToInt(eMsgNum.Text)) then
    begin
        mResponse.Items.Text := Copy(POP.LastResponse, 1, 10000);
        Screen.Cursor := crDefault;
        bRefreshClick(Sender);
    end
    else
    begin
        Screen.Cursor := crDefault;
        ShowMessage('Failed on retrieve');
    end
end;

procedure TMainForm.bRefreshClick(Sender: TObject);
var
    Loop: Integer;
    Text: String;
begin
    Screen.Cursor := crHourglass;
    SetLength(Text, Msg.Body.Size);
    if Length(Text) > 0 then
    begin
        Msg.Body.Position := 0;
        Msg.Body.ReadBuffer(Text[1], Msg.Body.Size);
    end;
    mHeader.Lines.Text := Copy(Msg.Header.Text, 1, 10000);
    mBody.Lines.Text := Copy(Text, 1, 10000);
    eFromName.Text := Msg.FromName;
    eFromAddress.Text := Msg.FromAddress;
    eReplyName.Text := Msg.ReplyToName;
    eReplyAddress.Text := Msg.ReplyToAddress;
    eSubject.Text := Msg.Subject;
    dtDate.DateTime := Msg.Date;
    dtTime.DateTime := Msg.Date;
    mToNames.Clear;
    mToAddresses.Clear;
    mCcNames.Clear;
    mCcAddresses.Clear;
    lbFiles.Clear;
    Msg.GetAttachList;
    mTextPlain.Lines.Text := Msg.TextPlain.Text;
    mTextHtml.Lines.Text := Msg.TextHTML.Text;
    for Loop := 0 to Msg.ToCount-1 do
    begin
        mToNames.Lines.Add(Msg.ToName[Loop]);
        mToAddresses.Lines.Add(Msg.ToAddress[Loop]);
    end;
    for Loop := 0 to Msg.CcCount-1 do
    begin
        mCcNames.Lines.Add(Msg.CcName[Loop]);
        mCcAddresses.Lines.Add(Msg.CcAddress[Loop]);
    end;
    for Loop := 0 to Msg.AttachList.Count-1 do
    begin
        if Msg.AttachList[Loop].Decoded.Size = 0 then
            Msg.AttachList[Loop].Decode;
        lbFiles.Items.Add(Msg.AttachList[Loop].FileName+#32'('+IntToStr(Msg.AttachList[Loop].Decoded.Size)+')'#32+Msg.AttachList[Loop].AttachInfo);
    end;
    if Msg.NeedRebuild then
        MsgStatus.Caption := 'Message body needs rebuild'
    else
        MsgStatus.Caption := '';
    Screen.Cursor := crDefault;
end;

procedure TMainForm.bRebuildClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    Msg.RebuildBody;
    bRefreshClick(Sender);
    Screen.Cursor := crDefault;
end;

procedure TMainForm.bResetClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    Msg.Reset;
    Screen.Cursor := crDefault;
    bRefreshClick(Sender);
end;

procedure TMainForm.bLabelClick(Sender: TObject);
begin
    Msg.SetLabelValue(eLabel.Text, eValue.Text);
    bRefreshClick(Sender);
end;

procedure TMainForm.bDelLabelClick(Sender: TObject);
begin
    Msg.SetLabelValue(eLabel.Text, '');
    bRefreshClick(Sender);
end;

procedure TMainForm.bSaveHeaderClick(Sender: TObject);
var
    Loop: Integer;
begin
    Screen.Cursor := crHourglass;
    Msg.ClearTo;
    Msg.ClearCc;
    Msg.SetFrom(eFromName.Text, eFromAddress.Text);
    if eReplyAddress.Text <> '' then Msg.SetReplyTo(eReplyName.Text, eReplyAddress.Text);
    Msg.Subject := eSubject.Text;
    Msg.Date := Now;
    for Loop := 0 to mToNames.Lines.Count-1 do
    begin
        Msg.AddTo(mToNames.Lines[Loop], mToAddresses.Lines[Loop]);
    end;
    for Loop := 0 to mCcNames.Lines.Count-1 do
    begin
        Msg.AddCc(mCcNames.Lines[Loop], mCcAddresses.Lines[Loop]);
    end;
    Screen.Cursor := crDefault;
    bRefreshClick(Sender);
end;

procedure TMainForm.bSaveClick(Sender: TObject);
begin
    SaveDialog.FileName := Msg.AttachList[lbFiles.ItemIndex].FileName;
    if SaveDialog.Execute then
    begin
        Screen.Cursor := crHourglass;
        Msg.AttachList[lbFiles.ItemIndex].Decoded.SaveToFile(SaveDialog.FileName);
        Screen.Cursor := crDefault;
    end;
end;

procedure TMainForm.bAttachClick(Sender: TObject);
begin
    if OpenDialog.Execute then
    begin
        Screen.Cursor := crHourglass;
        Msg.AttachFile(OpenDialog.FileName);
        bRefreshClick(Sender);
        Screen.Cursor := crDefault;
    end;
end;

procedure TMainForm.bPlainClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    Msg.SetTextPlain(mTextPlain.Lines);
    bRefreshClick(Sender);
    Screen.Cursor := crDefault;
end;

procedure TMainForm.bHtmlClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    Msg.SetTextHTML(mTextHtml.Lines);
    bRefreshClick(Sender);
    Screen.Cursor := crDefault;
end;

procedure TMainForm.FormShow(Sender: TObject);
begin
    PageControl1.ActivePage := PageControl1.Pages[0];
    PageControl2.ActivePage := PageControl2.Pages[0];
end;

procedure TMainForm.bSaveMsgClick(Sender: TObject);
begin
    SaveDialog.FileName := 'message.eml';
    if SaveDialog.Execute then
    begin
        Screen.Cursor := crHourglass;
        Msg.SaveToFile(OpenDialog.FileName);
        Screen.Cursor := crDefault;
    end;
end;

procedure TMainForm.bSmtpConnectClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    SMTP.Host := eSmtpHost.Text;
    SMTP.Port := StrToInt(eSmtpPort.Text);
    if SMTP.Connect then
    begin
        mSmtpResponse.Items.Text := SMTP.LastResponse;
        bSmtpDisconnect.Enabled := True;
        bSend.Enabled := True;
        Screen.Cursor := crDefault;
    end
    else
    begin
        Screen.Cursor := crDefault;
        ShowMessage('Failed on connect');
    end;
end;

procedure TMainForm.bSmtpDisconnectClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    if SMTP.Quit then
    begin
        mSmtpResponse.Items.Add(SMTP.LastResponse);
        bSmtpDisconnect.Enabled := False;
        bSend.Enabled := False;
        Screen.Cursor := crDefault;
    end
    else
    begin
        Screen.Cursor := crDefault;
        ShowMessage('Failed on quit');
    end;
end;

procedure TMainForm.bSendClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    if SMTP.SendMessage then
    begin
        mSmtpResponse.Items.Add(SMTP.LastResponse);
        Screen.Cursor := crDefault;
    end
    else
    begin
        Screen.Cursor := crDefault;
        ShowMessage('Failed on send');
    end;
end;

procedure TMainForm.bLoadMsgClick(Sender: TObject);
begin
    if OpenDialog.Execute then
    begin
        Screen.Cursor := crHourglass;
        Msg.LoadFromFile(OpenDialog.FileName);
        Screen.Cursor := crDefault;
        bRefreshClick(Sender);
    end;
end;

procedure TMainForm.bRemoveClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    Msg.AttachList[lbFiles.ItemIndex].Remove;
    Screen.Cursor := crDefault;
    bRefreshClick(Sender);
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
    if POP.SessionConnected or SMTP.SessionConnected then Action := caNone;
end;

procedure TMainForm.POPProgress(Sender: TObject; Total, Current: Integer);
begin
    ProgressBar1.Max := Total;
    ProgressBar1.Position := Current;
end;

procedure TMainForm.MsgProgress(Sender: TObject; Total, Current: Integer);
begin
    ProgressBar2.Max := Total;
    ProgressBar2.Position := Current;
end;

procedure TMainForm.SMTPProgress(Sender: TObject; Total, Current: Integer);
begin
    ProgressBar3.Max := Total;
    ProgressBar3.Position := Current;
end;

procedure TMainForm.bPlainRemoveClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    Msg.RemoveTextPlain;
    Screen.Cursor := crDefault;
    bRefreshClick(Sender);
end;

procedure TMainForm.bHtmlRemoveClick(Sender: TObject);
begin
    Screen.Cursor := crHourglass;
    Msg.RemoveTextHTML;
    Screen.Cursor := crDefault;
    bRefreshClick(Sender);
end;

end.