|
Проектирование и разработка сетевых броузеров на основе теоретико-графовых моделей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 |
|
