Проектирование и разработка сетевых броузеров на основе теоретико-графовых моделей

end;

procedure TMyFtp.ViewListItemClick(Sender: TObject);

begin

FileList.ViewStyle := vsList;

end;

procedure TMyFtp.ViewDetailsItemClick(Sender: TObject);

begin

FileList.ViewStyle := vsReport;

end;

procedure TMyFtp.ViewRefreshItemClick(Sender: TObject);

begin

DirTreeChange(nil, DirTree.Selected);

end;

procedure TMyFtp.CopyItemClick(Sender: TObject);

begin

SaveDialog1.FileName := FileList.Selected.Caption;

if SaveDialog1.Execute then

FTP.GetFile(NodePath(DirTree.Selected) + '/' +

FileList.Selected.Caption,

SaveDialog1.FileName);

end;

procedure TMyFtp.ToolsDisconnectItemClick(Sender: TObject);

begin

DisConnect;

end;

procedure TMyFtp.FileNewItemClick(Sender: TObject);

var

DirName: String;

begin

if InputQuery('Input Box', 'Prompt', DirName) then

FTP.CreateDir(NodePath(DirTree.Selected) + '/' + DirName);

end;

procedure TMyFtp.DeleteItemClick(Sender: TObject);

begin

if ActiveControl = DirTree then

FTP.DeleteDir(NodePath(DirTree.Selected));

if ActiveControl = FileList then

FTP.DeleteFile(NodePath(DirTree.Selected) + '/' +

FileList.Selected.Caption);

end;

procedure TMyFtp.PasteFromItemClick(Sender: TObject);

begin

if OpenDialog1.Execute then

FTP.PutFile(OpenDialog1.FileName, NodePath(DirTree.Selected));

end;

procedure TMyFtp.FilePopupPopup(Sender: TObject);

begin

CopyItem.Enabled := (ActiveControl = FileList) and (FileList.Selected

<> nil);

PasteFromItem.Enabled := (ActiveControl = DirTree) and

(DirTree.Selected <> nil);

DeleteItem.Enabled := (ActiveControl = FileList) and

(FileList.Selected <> nil);

RenameItem.Enabled := (ActiveControl = FileList) and

(FileList.Selected <> nil);

end;

procedure TMyFtp.FileMenuClick(Sender: TObject);

begin

FileCopyItem.Enabled := (ActiveControl = FileList) and

(FileList.Selected <> nil);

FileDeleteItem.Enabled := (ActiveControl = FileList) and

(FileList.Selected <> nil);

FileRenameItem.Enabled := (ActiveControl = FileList) and

(FileList.Selected <> nil);

end;

procedure TMyFtp.FileDeleteItemClick(Sender: TObject);

begin

if (DirTree.Selected <> nil) and (FileList.Selected <> nil) then

FTP.DeleteFile(FileList.Selected.Caption);

end;

procedure TMyFtp.FTPListItem(Sender: TObject; const Item: FTPDirItem);

var

Node: TTreeNode;

begin

CreateItem(Item.FileName, Item.Attributes, Item.Size, Item.Date);

if Item.Attributes = 1 then

if DirTree.Selected <> nil then

begin

if DirTree.Selected <> nil then

Node := DirTree.Selected.GetFirstChild

else

Node := nil;

while Node <> nil do

if AnsiCompareFileName(Node.Text, Item.FileName) = 0 then

exit

else

Node := DirTree.Selected.GetNextChild(Node);

if Node = nil then

begin

Node := DirTree.Items.AddChild(DirTree.Selected,

Item.FileName);

Node.ImageIndex := Folder;

Node.SelectedIndex := OpenFolder;

end;

end

else

DirTree.Items.AddChild(Root, Item.FileName);

end;

end.

Дз п№л€ркозтфрCх;уАчх(ы‚хXюKхёюЫф@ьuу(ъfфяьюМ‡

1EF

№

юЁьsхmу0хттыьшфайл nntp.pas

unit nntp;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs,

Menus, OleCtrls, StdCtrls, ComCtrls, ExtCtrls, Buttons, ActiveX, isp3;

const

efListGroups = 0;

efGetArticleHeaders = 1;

efGetArticleNumbers = 2;

efGetArticle = 3;

type

TNewsForm = class(TForm)

NNTP1: TNNTP;

MainMenu1: TMainMenu;

File1: TMenuItem;

Exit1: TMenuItem;

N1: TMenuItem;

FileDisconnectItem: TMenuItem;

FileConnectItem: TMenuItem;

Panel1: TPanel;

Bevel1: TBevel;

StatusBar: TStatusBar;

SmallImages: TImageList;

Panel2: TPanel;

NewsGroups: TTreeView;

Bevel2: TBevel;

Panel3: TPanel;

Memo1: TMemo;

Panel5: TPanel;

Panel4: TPanel;

ConnectBtn: TSpeedButton;

RefreshBtn: TSpeedButton;

Bevel3: TBevel;

MsgHeaders: TListBox;

Label1: TLabel;

Label2: TLabel;

procedure FileConnectItemClick(Sender: TObject);

procedure NNTP1ProtocolStateChanged(Sender: TObject;

ProtocolState: Smallint);

procedure NNTP1StateChanged(Sender: TObject; State: Smallint);

procedure Exit1Click(Sender: TObject);

procedure MsgHeadersDblClick(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure NewsGroupsChange(Sender: TObject; Node: TTreeNode);

procedure RefreshBtnClick(Sender: TObject);

procedure FileDisconnectItemClick(Sender: TObject);

procedure NNTP1Banner(Sender: TObject; const Banner: WideString);

procedure NNTP1DocOutput(Sender: TObject; const DocOutput:

DocOutput);

procedure NNTP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer;

var CancelDisplay: WordBool);

procedure NNTP1SelectGroup(Sender: TObject;

const groupName: WideString; firstMessage, lastMessage,

msgCount: Integer);

private

EventFlag: Integer;

function NodePath(Node: TTreeNode): String;

public

Data: String;

end;

var

NewsForm: TNewsForm;

Remainder: String;

Nodes: TStringList;

CurrentGroup: String;

GroupCount: Integer;

implementation

uses Connect;

{$R *.DFM}

{ TParser }

type

TToken = (etEnd, etSymbol, etName, etLiteral);

TParser = class

private

FFlags: Integer;

FText: string;

FSourcePtr: PChar;

FSourceLine: Integer;

FTokenPtr: PChar;

FTokenString: string;

FToken: TToken;

procedure SkipBlanks;

procedure NextToken;

public

constructor Create(const Text: string; Groups: Boolean);

end;

const

sfAllowSpaces = 1;

constructor TParser.Create(const Text: string; Groups: Boolean);

begin

FText := Text;

FSourceLine := 1;

FSourcePtr := PChar(Text);

if Groups then

FFlags := sfAllowSpaces

else

FFlags := 0;

NextToken;

end;

procedure TParser.SkipBlanks;

begin

while True do

begin

case FSourcePtr^ of

#0:

begin

if FSourcePtr^ = #0 then Exit;

Continue;

end;

#10:

Inc(FSourceLine);

#33..#255:

Exit;

end;

Inc(FSourcePtr);

end;

end;

procedure TParser.NextToken;

var

P, TokenStart: PChar;

begin

SkipBlanks;

FTokenString := '';

P := FSourcePtr;

while (P^ <> #0) and (P^ etEnd do

begin

if Parser.FSourceLine <> OldSrcLine then

begin

AddItem(Parser.FTokenString);

OldSrcLine := Parser.FSourceLine;

end;

Parser.NextToken;

end;

end;

procedure ParseHeaders(Data: String);

var

Parser: TParser;

MsgNo: LongInt;

Header: String;

OldSrcLine: Integer;

begin

Parser := TParser.Create(Data, False);

while Parser.FToken <> etEnd do

begin

MsgNo := StrToInt(Parser.FTokenString);

OldSrcLine := Parser.FSourceLine;

Parser.NextToken;

Header := '';

while (OldSrcLine = Parser.FSourceLine) do

begin

Header := Header + ' ' + Parser.FTokenString;

Parser.NextToken;

if Parser.FToken = etEnd then

Break;

end;

NewsForm.MsgHeaders.Items.AddObject(Header, Pointer(MsgNo));

end;

end;

procedure DestroyList(AList: TStringList);

var

i: Integer;

begin

for i := 0 to AList.Count - 1 do

if AList.Objects[i] <> nil then

DestroyList(TStringList(AList.Objects[i]));

AList.Free;

end;

procedure BuildTree(Parent: TTreeNode; List: TStrings);

var

i: Integer;

Node: TTreeNode;

begin

for i := 0 to List.Count - 1 do

if List.Objects[i] <> nil then

begin

Node := NewsForm.NewsGroups.Items.AddChild(Parent, List[i]);

Node.ImageIndex := 0;

Node.SelectedIndex := 1;

BuildTree(Node, TStrings(List.Objects[i]));

end

else

NewsForm.NewsGroups.Items.AddChild(Parent, List[i]);

end;

function TNewsForm.NodePath(Node: TTreeNode): String;

begin

if Node.Parent = nil then

Result := Node.Text

else

Result := NodePath(Node.Parent) + '.' + Node.Text;

end;

procedure TNewsForm.FileConnectItemClick(Sender: TObject);

begin

ConnectDlg := TConnectDlg.Create(Self);

try

if ConnectDlg.ShowModal = mrOk then

with NNTP1 do

Connect(ConnectDlg.ServerEdit.Text, RemotePort);

finally

ConnectDlg.Free;

end;

end;

procedure TNewsForm.NNTP1ProtocolStateChanged(Sender: TObject;

ProtocolState: Smallint);

begin

case ProtocolState of

nntpBase: ;

nntpTransaction:

begin

EventFlag := efListGroups;

Nodes := TStringList.Create;

Nodes.Sorted := True;

NNTP1.ListGroups;

end;

end;

end;

procedure TNewsForm.NNTP1StateChanged(Sender: TObject; State: Smallint);

begin

with Memo1.Lines do

case NNTP1.State of

prcConnecting : Add('Connecting');

prcResolvingHost: Add('Resolving Host: ' + NNTP1.RemoteHost);

prcHostResolved : Add('Host resolved');

prcConnected :

begin

Add('Connected to: ' + NNTP1.RemoteHost);

Statusbar.Panels[0].Text := 'Connected to: ' +

NNTP1.RemoteHost;

ConnectBtn.Enabled := False;

FileConnectItem.Enabled := False;

RefreshBtn.Enabled := True;

end;

prcDisconnecting: Text := NNTP1.ReplyString;

prcDisconnected :

begin

Statusbar.Panels[0].Text := 'Disconnected';

Caption := 'News Reader';

Label1.Caption := '';

ConnectBtn.Enabled := True;

FileConnectItem.Enabled := True;

RefreshBtn.Enabled := False;

end;

end;

end;

procedure TNewsForm.Exit1Click(Sender: TObject);

begin

if NNTP1.State <> prcDisconnected then

begin

if NNTP1.Busy then NNTP1.Cancel;

NNTP1.Quit;

while NNTP1.State <> prcDisconnected do

Application.ProcessMessages;

end;

Close;

end;

procedure TNewsForm.MsgHeadersDblClick(Sender: TObject);

var

Article: Integer;

begin

if NNTP1.Busy then exit;

EventFlag := efGetArticle;

Memo1.Clear;

if MsgHeaders.ItemIndex = -1 then exit;

Caption := 'News Reader: ' + MsgHeaders.Items[MsgHeaders.ItemIndex];

Article := Integer(MsgHeaders.Items.Objects[MsgHeaders.ItemIndex]);

NNTP1.GetArticlebyArticleNumber(Article);

end;

procedure TNewsForm.FormClose(Sender: TObject; var Action:

TCloseAction);

begin

if NNTP1.State <> prcDisconnected then

begin

if NNTP1.Busy then NNTP1.Cancel;

NNTP1.Quit;

while NNTP1.State <> prcDisconnected do

Application.ProcessMessages;

end;

end;

procedure TNewsForm.NewsGroupsChange(Sender: TObject; Node: TTreeNode);

var

NP: String;

begin

if (NNTP1.State = prcConnected) and not NNTP1.Busy then

with MsgHeaders do

begin

Items.BeginUpdate;

try

Items.Clear;

Memo1.Lines.Clear;

NP := NodePath(NewsGroups.Selected);

Statusbar.Panels[2].Text := 'Bytes: 0';

Statusbar.Panels[1].Text := '0 Article(s)';

if NNTP1.Busy then

NNTP1.Cancel;

NNTP1.SelectGroup(NP);

Label1.Caption := 'Contents of ''' + NP + '''';

finally

Items.EndUpdate;

end;

end;

end;

procedure TNewsForm.RefreshBtnClick(Sender: TObject);

begin

if NewsGroups.Selected <> nil then

NewsGroupsChange(nil, NewsGroups.Selected);

end;

procedure TNewsForm.FileDisconnectItemClick(Sender: TObject);

begin

if NNTP1.Busy then NNTP1.Cancel;

NNTP1.Quit;

while NNTP1.Busy do

Application.ProcessMessages;

with NewsGroups.Items do

begin

BeginUpdate;

Clear;

EndUpdate;

end;

MsgHeaders.Items.Clear;

Memo1.Lines.Clear;

end;

procedure TNewsForm.NNTP1Banner(Sender: TObject; const Banner:

WideString);

begin

Memo1.Lines.Add(Banner);

end;

procedure TNewsForm.NNTP1DocOutput(Sender: TObject;

const DocOutput: DocOutput);

begin

Statusbar.Panels[2].Text := Format('Bytes:

%d',[DocOutput.BytesTransferred]);

case DocOutput.State of

icDocBegin:

begin

if EventFlag = efListGroups then

Memo1.Lines.Add('Retrieving news groups...');

Data := '';

GroupCount := 0;

end;

icDocData:

begin

Data := Data + DocOutput.DataString;

if EventFlag = efGetArticle then

Memo1.Lines.Add(Data);

end;

icDocEnd:

begin

case EventFlag of

efListGroups:

begin

ParseGroups(Data);

Memo1.Lines.Add('Done.'#13#10'Building news group

tree...');

NewsGroups.Items.BeginUpdate;

try

BuildTree(nil, Nodes);

DestroyList(Nodes);

Statusbar.Panels[1].Text := Format('%d

Groups',[GroupCount]);

finally

NewsGroups.Items.EndUpdate;

Memo1.Lines.Add('Done.');

end;

end;

efGetArticleHeaders: ParseHeaders(Data);

efGetArticle:

begin

Memo1.SelStart := 0;

SendMessage(Memo1.Handle, EM_ScrollCaret, 0, 0);

end;

end;

SetLength(Data, 0);

end;

end;

Refresh;

end;

procedure TNewsForm.NNTP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer; var CancelDisplay:

WordBool);

begin

// MessageDlg(Description, mtError, [mbOk], 0);

end;

procedure TNewsForm.NNTP1SelectGroup(Sender: TObject;

const groupName: WideString; firstMessage, lastMessage,

msgCount: Integer);

begin

EventFlag := efGetArticleHeaders;

Statusbar.Panels[1].Text := Format('%d Article(s)',[msgCount]);

NNTP1.GetArticleHeaders('subject', FirstMessage, lastMessage);

end;

end.

файл smtp.pas

unit Smtp;

interface

uses Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus,

StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, ComCtrls, OleCtrls,

ISP3;

type

TMail = class(TForm)

OpenDialog: TOpenDialog;

SMTP1: TSMTP;

POP1: TPOP;

PageControl1: TPageControl;

SendPage: TTabSheet;

RecvPage: TTabSheet;

ConPage: TTabSheet;

Panel1: TPanel;

Label1: TLabel;

Label3: TLabel;

Label2: TLabel;

eTo: TEdit;

eCC: TEdit;

eSubject: TEdit;

SendBtn: TButton;

ClearBtn: TButton;

reMessageText: TRichEdit;

SMTPStatus: TStatusBar;

Panel3: TPanel;

mReadMessage: TMemo;

POPStatus: TStatusBar;

cbSendFile: TCheckBox;

GroupBox1: TGroupBox;

ePOPServer: TEdit;

Label6: TLabel;

Label5: TLabel;

eUserName: TEdit;

ePassword: TEdit;

Label4: TLabel;

GroupBox2: TGroupBox;

Label7: TLabel;

eSMTPServer: TEdit;

SMTPConnectBtn: TButton;

POPConnectBtn: TButton;

eHomeAddr: TEdit;

Label8: TLabel;

Panel2: TPanel;

Label9: TLabel;

lMessageCount: TLabel;

Label10: TLabel;

eCurMessage: TEdit;

udCurMessage: TUpDown;

ConnectStatus: TStatusBar;

procedure FormCreate(Sender: TObject);

procedure POP1StateChanged(Sender: TObject; State: Smallint);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure SMTP1StateChanged(Sender: TObject; State: Smallint);

procedure FormResize(Sender: TObject);

procedure ClearBtnClick(Sender: TObject);

procedure SMTP1Verify(Sender: TObject);

procedure SendBtnClick(Sender: TObject);

procedure POP1ProtocolStateChanged(Sender: TObject;

ProtocolState: Smallint);

procedure SMTPConnectBtnClick(Sender: TObject);

procedure POPConnectBtnClick(Sender: TObject);

procedure eSMTPServerChange(Sender: TObject);

procedure ePOPServerChange(Sender: TObject);

procedure cbSendFileClick(Sender: TObject);

procedure udCurMessageClick(Sender: TObject; Button: TUDBtnType);

procedure POP1RefreshMessageCount(Sender: TObject; Number: Integer);

procedure POP1DocOutput(Sender: TObject; const DocOutput:

DocOutput);

procedure POP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer;

var CancelDisplay: WordBool);

procedure SMTP1DocInput(Sender: TObject; const DocInput: DocInput);

procedure SMTP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer;

var CancelDisplay: WordBool);

private

RecvVerified,

SMTPError,

POPError: Boolean;

FMessageCount: Integer;

procedure SendFile(Filename: string);

procedure SendMessage;

procedure CreateHeaders;

end;

var

Mail: TMail;

implementation

{$R *.DFM}

const

icDocBegin = 1;

icDocHeaders = 2;

icDocData = 3;

icDocEnd = 5;

{When calling a component method which maps onto an OLE call, NoParam

substitutes

for an optional parameter. As an alternative to calling the component

method, you

may access the component's OLEObject directly -

i.e., Component.OLEObject.MethodName(,Foo,,Bar)}

function NoParam: Variant;

begin

TVarData(Result).VType := varError;

TVarData(Result).VError := DISP_E_PARAMNOTFOUND;

end;

procedure TMail.FormCreate(Sender: TObject);

begin

SMTPError := False;

POPError := False;

FMessageCount := 0;

end;

procedure TMail.FormClose(Sender: TObject; var Action: TCloseAction);

begin

if POP1.State = prcConnected then POP1.Quit;

if SMTP1.State = prcConnected then SMTP1.Quit;

end;

procedure TMail.FormResize(Sender: TObject);

begin

SendBtn.Left := ClientWidth - SendBtn.Width - 10;

ClearBtn.Left := ClientWidth - ClearBtn.Width - 10;

cbSendFile.Left := ClientWidth - cbSendFile.Width - 10;

eTo.Width := SendBtn.Left - eTo.Left - 10;

eCC.Width := SendBtn.Left - eCC.Left - 10;

eSubject.Width := SendBtn.Left - eSubject.Left - 10;

end;

procedure TMail.ClearBtnClick(Sender: TObject);

begin

eTo.Text := '';

eCC.Text := '';

eSubject.Text := '';

OpenDialog.Filename := '';

reMessageText.Lines.Clear;

end;

procedure TMail.eSMTPServerChange(Sender: TObject);

begin

SMTPConnectBtn.Enabled := (eSMTPServer.Text <> '') and (eHomeAddr.Text

<> '');

end;

procedure TMail.ePOPServerChange(Sender: TObject);

begin

POPConnectBtn.Enabled := (ePOPServer.Text <> '') and (eUsername.Text

<> '')

and (ePassword.Text <> '');

end;

procedure TMail.cbSendFileClick(Sender: TObject);

begin

if cbSendFile.Checked then

begin

if OpenDialog.Execute then

cbSendFile.Caption := cbSendFile.Caption + ':

'+OpenDialog.Filename

else

cbSendFile.Checked := False;

end else

cbSendFile.Caption := '&Attach Text File';

end;

{Clear and repopulate MIME headers, using the component's DocInput

property. A

separate DocInput OLE object could also be used. See RFC1521/1522 for

complete

information on MIME types.}

procedure TMail.CreateHeaders;

begin

with SMTP1 do

begin

DocInput.Headers.Clear;

DocInput.Headers.Add('To', eTo.Text);

DocInput.Headers.Add('From', eHomeAddr.Text);

DocInput.Headers.Add('CC', eCC.Text);

DocInput.Headers.Add('Subject', eSubject.Text);

DocInput.Headers.Add('Message-Id', Format('%s_%s_%s',

[Application.Title,

DateTimeToStr(Now), eHomeAddr.Text]));

DocInput.Headers.Add('Content-Type', 'TEXT/PLAIN charset=US-ASCII');

end;

end;

{Send a simple mail message}

procedure TMail.SendMessage;

begin

CreateHeaders;

with SMTP1 do

SendDoc(NoParam, DocInput.Headers, reMessageText.Text, '', '');

end;

{Send a disk file. Leave SendDoc's InputData parameter blank and

specify a filename for InputFile to send the contents of a disk file.

You can

use the DocInput event and GetData methods to do custom encoding

(Base64, UUEncode, etc.) }

procedure TMail.SendFile(Filename: string);

begin

CreateHeaders;

with SMTP1 do

begin

DocInput.Filename := FileName;

SendDoc(NoParam, DocInput.Headers, NoParam, DocInput.FileName, '');

end;

end;

{Set global flag indicating recipients are addressable (this only

ensures that the

address is in the correct format, not that it exists and is

deliverable), then

send the text part of the message}

procedure TMail.SMTP1Verify(Sender: TObject);

begin

SendMessage;

RecvVerified := True;

end;

{Verify addressees, send text message in the Verify event, and if an

attachment is

specified, send it}

procedure TMail.SendBtnClick(Sender: TObject);

var

Addressees: string;

begin

if SMTP1.State = prcConnected then

begin

RecvVerified := False;

SMTPError := False;

Addressees := eTo.Text;

if eCC.Text <> '' then

Addressees := Addressees + ', '+ eCC.Text;

SMTP1.Verify(Addressees);

{wait for completion of Verify-Text message send}

while SMTP1.Busy do

Application.ProcessMessages;

{Check global flag indicating addresses are in the correct format -

if true,

the text part of the message has been sent}

if not RecvVerified then

begin

MessageDlg('Incorrect address format', mtError, [mbOK], 0);

Exit;

end

else

if cbSendFile.Checked then

SendFile(OpenDialog.Filename);

end

else

MessageDlg('Not connected to SMTP server', mtError, [mbOK], 0);

end;

{SMTP component will call this event every time its connection state

changes}

procedure TMail.SMTP1StateChanged(Sender: TObject; State: Smallint);

begin

case State of

prcConnecting:

ConnectStatus.SimpleText := 'Connecting to SMTP server:

'+SMTP1.RemoteHost+'...';

prcResolvingHost:

ConnectStatus.SimpleText := 'Resolving Host';

prcHostResolved:

ConnectStatus.SimpleText := 'Host Resolved';

prcConnected:

begin

ConnectStatus.SimpleText := 'Connected to SMTP server:

'+SMTP1.RemoteHost;

SMTPConnectBtn.Caption := 'Disconnect';

end;

prcDisconnecting:

ConnectStatus.SimpleText := 'Disconnecting from SMTP server:

'+SMTP1.RemoteHost+'...';

prcDisconnected:

begin

ConnectStatus.SimpleText := 'Disconnected from SMTP server:

'+SMTP1.RemoteHost;

SMTPConnectBtn.Caption := 'Connect';

end;

end;

eSMTPServer.Enabled := not (State = prcConnected);

eHomeAddr.Enabled := not (State = prcConnected);

end;

{The DocInput event is called each time the DocInput state changes

during a mail transfer.

DocInput holds all the information about the current transfer, including

the headers, the

number of bytes transferred, and the message data itself. Although not

shown in this example,

you may call DocInput's SetData method if DocInput.State = icDocData to

encode the data before

each block is sent.}

procedure TMail.SMTP1DocInput(Sender: TObject;

const DocInput: DocInput);

begin

case DocInput.State of

icDocBegin:

SMTPStatus.SimpleText := 'Initiating document transfer';

icDocHeaders:

SMTPStatus.SimpleText := 'Sending headers';

icDocData:

if DocInput.BytesTotal > 0 then

SMTPStatus.SimpleText := Format('Sending data: %d of %d bytes

(%d%%)',

[Trunc(DocInput.BytesTransferred), Trunc(DocInput.BytesTotal),

Trunc(DocInput.BytesTransferred/DocInput.BytesTotal*100)])

else

SMTPStatus.SimpleText := 'Sending...';

icDocEnd:

if SMTPError then

SMTPStatus.SimpleText := 'Transfer aborted'

else

SMTPStatus.SimpleText := Format('Mail sent to %s (%d bytes

data)', [eTo.Text,

Trunc(DocInput.BytesTransferred)]);

end;

SMTPStatus.Update;

end;

{The Error event is called whenever an error occurs in the background

processing. In

addition to providing an error code and brief description, you can also

access the SMTP

component's Errors property (of type icErrors, an OLE object) to get

more detailed

information}

procedure TMail.SMTP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer; var CancelDisplay:

WordBool);

var

I: Integer;

ErrorStr: string;

begin

SMTPError := True;

CancelDisplay := True;

{Get extended error information}

for I := 1 to SMTP1.Errors.Count do

ErrorStr := Format(#13'(%s)', [SMTP1.Errors.Item(I).Description]);

{Display error code, short and long error description}

MessageDlg(Format('%d - %s%s', [Number, Description, Trim(ErrorStr)]),

mtError, [mbOK], 0);

end;

{Unlike POP, SMTP does not require a user account on the host machine,

so no user

authorization is necessary}

procedure TMail.SMTPConnectBtnClick(Sender: TObject);

begin

if SMTP1.State = prcConnected then

SMTP1.Quit

else

if SMTP1.State = prcDisconnected then

begin

SMTP1.RemoteHost := eSMTPServer.Text;

SMTPError := False;

SMTP1.Connect(NoParam, NoParam);

end;

end;

{Unlike SMTP, users must be authorized on the POP server. The component

defines

a special protocol state, popAuthorization, when it requests

authorization. If

authorization is successful, the protocol state changes to

popTransaction and

POP commands can be issued. Note that server connection is independent

of the

authorization state.}

procedure TMail.POP1ProtocolStateChanged(Sender: TObject;

ProtocolState: Smallint);

begin

case ProtocolState of

popAuthorization:

POP1.Authenticate(POP1.UserID, POP1.Password);

popTransaction:

ConnectStatus.SimpleText := Format('User %s authorized on server

%s', [eUsername.Text,

ePOPServer.Text]);

end;

end;

{This event is called every time the connection status of the POP server

changes}

procedure TMail.POP1StateChanged(Sender: TObject; State: Smallint);

begin

case State of

prcConnecting:

ConnectStatus.SimpleText := 'Connecting to POP server:

'+POP1.RemoteHost+'...';

prcResolvingHost:

ConnectStatus.SimpleText := 'Resolving Host';

prcHostResolved:

ConnectStatus.SimpleText := 'Host Resolved';

prcConnected:

begin

ConnectStatus.SimpleText := 'Connected to POP server:

'+POP1.RemoteHost;

POPConnectBtn.Caption := 'Disconnect';

end;

prcDisconnecting:

ConnectStatus.SimpleText := 'Disconnecting from POP server:

'+POP1.RemoteHost+'...';

prcDisconnected:

begin

ConnectStatus.SimpleText := 'Disconnected from POP server:

'+POP1.RemoteHost;

POPConnectBtn.Caption := 'Connect';

end;

end;

ePOPServer.Enabled := not (State = prcConnected);

eUsername.Enabled := not (State = prcConnected);

ePassword.Enabled := not (State = prcConnected);

end;

{The Error event is called whenever an error occurs in the background

processing. In

addition to providing an error code and brief description, you can also

access the POP

component's Errors property (of type icErrors, an OLE object) to get

more detailed

information}

procedure TMail.POP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer; var CancelDisplay:

WordBool);

var

I: Integer;

ErrorStr: string;

begin

POPError := True;

CancelDisplay := True;

if POP1.ProtocolState = popAuthorization then

ConnectStatus.SimpleText := 'Authorization error';

{Get extended error information}

for I := 1 to POP1.Errors.Count do

ErrorStr := Format(#13'(%s)', [POP1.Errors.Item(I).Description]);

{Display error code, short and long error description}

MessageDlg(Format('%d - %s%s', [Number, Description, Trim(ErrorStr)]),

mtError, [mbOK], 0);

end;

{POP requires a valid user account on the host machine}

procedure TMail.POPConnectBtnClick(Sender: TObject);

begin

if (POP1.State = prcConnected) and (POP1.ProtocolState =

popTransaction)

and not POP1.Busy then

begin

mReadMessage.Lines.Clear;

POP1.Quit;

end

else

if POP1.State = prcDisconnected then

begin

POP1.RemoteHost := ePOPServer.Text;

POP1.UserID := eUserName.Text;

POP1.Password := ePassword.Text;

POP1.Connect(NoParam, NoParam);

end;

end;

{The DocOutput event is the just like the DocInput event in 'reverse'.

It is called each time

the component's DocOutput state changes during retrieval of mail from

the server. When the

state = icDocData, you can call DocOutput.GetData to decode each data

block based on the MIME

content type specified in the headers.}

procedure TMail.POP1DocOutput(Sender: TObject; const DocOutput:

DocOutput);

var

Buffer: WideString;

I: Integer;

begin

case DocOutput.State of

icDocBegin:

POPStatus.SimpleText := 'Initiating document transfer';

icDocHeaders:

begin

POPStatus.SimpleText := 'Retrieving headers';

for I := 1 to DocOutput.Headers.Count do

mReadMessage.Lines.Add(DocOutput.Headers.Item(I).Name+': '+

DocOutput.Headers.Item(I).Value);

end;

icDocData:

begin

POPStatus.SimpleText := Format('Retrieving data - %d bytes',

[Trunc(DocOutput.BytesTransferred)]);

Buffer := DocOutput.DataString;

mReadMessage.Text := mReadMessage.Text + Buffer;

end;

icDocEnd:

if POPError then

POPStatus.SimpleText := 'Transfer aborted'

else

POPStatus.SimpleText := Format('Retrieval complete (%d bytes

data)',

[Trunc(DocOutput.BytesTransferred)]);

end;

POPStatus.Update;

end;

{Retrieve message from the server}

procedure TMail.udCurMessageClick(Sender: TObject; Button: TUDBtnType);

begin

if (POP1.State = prcConnected) and (POP1.ProtocolState =

popTransaction) then

begin

POPError := False;

mReadMessage.Lines.Clear;

POP1.RetrieveMessage(udCurMessage.Position);

end;

end;

{The RefreshMessageCount event is called whenever the

RefreshMessageCount method is

Страницы: 1, 2, 3, 4, 5