46231 (Проектирование и разработка сетевых броузеров на основе теоретико-графовых моделей), страница 4

TheNodes := TStringList(TheNodes.Objects[Index]);

TheNodes.Sorted := True;

end

else

TheNodes := TStringList(TheNodes.Objects[Index]);

end;

Inc(GroupCount);

end;

procedure ParseGroups(Data: String);

var

Parser: TParser;

OldSrcLine: Integer;

begin

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

OldSrcLine := 0;

while Parser.FToken <> 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;