Пример FTP сервера

Previous  Top  Next

    
 

 

 

Code:

unit Unit1;

 

interface

 

uses

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

Dialogs, IdBaseComponent, IdComponent, IdUDPBase, IdUDPServer,

IdTrivialFTPServer, StdCtrls, IdUDPClient, IdTrivialFTP;

 

type

TForm1 = class(TForm)

   IdTrivialFTPServer1: TIdTrivialFTPServer;

   IdTrivialFTP1: TIdTrivialFTP;

   Button1: TButton;

   Button2: TButton;

   procedure FormCreate(Sender: TObject);

   procedure IdTrivialFTPServer1ReadFile(Sender: TObject;

     var FileName: string; const PeerInfo: TPeerInfo;

     var GrantAccess: Boolean; var AStream: TStream;

     var FreeStreamOnComplete: Boolean);

   procedure IdTrivialFTPServer1TransferComplete(Sender: TObject;

     const Success: Boolean; const PeerInfo: TPeerInfo; AStream: TStream;

     const WriteOperation: Boolean);

   procedure IdTrivialFTPServer1WriteFile(Sender: TObject;

     var FileName: string; const PeerInfo: TPeerInfo;

     var GrantAccess: Boolean; var AStream: TStream;

     var FreeStreamOnComplete: Boolean);

   procedure Button1Click(Sender: TObject);

   procedure Button2Click(Sender: TObject);

private

   { Private declarations }

public

   { Public declarations }

   TFTPPath: string;

end;

 

var

Form1: TForm1;

 

implementation

 

{$R *.dfm}

 

procedure TForm1.FormCreate(Sender: TObject);

begin

IdTrivialFTPServer1.ThreadedEvent := True;

IdTrivialFTPServer1.Active := True;

{ Set the path to where the files will be stored/retreived }

TFTPPath := IncludeTrailingPathDelimiter('C:\Temp');

end;

 

procedure TForm1.IdTrivialFTPServer1ReadFile(Sender: TObject;

var FileName: string; const PeerInfo: TPeerInfo;

var GrantAccess: Boolean; var AStream: TStream;

var FreeStreamOnComplete: Boolean);

var

FS: TFileStream;

begin

FreeStreamOnComplete := True;

try

   { Convert UNIX style filenames to WINDOWS style }

   while Pos('/', Filename) <> 0 do

     Filename[Pos('/', Filename)] := '\';

   { Assure that the filename DOES NOT CONTAIN any path information }

   Filename := ExtractFileName(Filename);

   { Check if file exists }

   if FileExists(TFTPPath + Filename) then

   begin

     { Open file in READ ONLY mode }

     FS := TFileStream.Create(TFTPPath + Filename,

       fmOpenRead or fmShareDenyWrite);

     { Assign stream to variable }

     AStream := FS;

     { Set parameters }

     GrantAccess := True;

   end

   else

   begin

     GrantAccess := False;

   end;

except

   { On errors, deny access }

   GrantAccess := False;

   if Assigned(FS) then

     FreeAndNil(FS);

end;

end;

 

procedure TForm1.IdTrivialFTPServer1WriteFile(Sender: TObject;

var FileName: string; const PeerInfo: TPeerInfo;

var GrantAccess: Boolean; var AStream: TStream;

var FreeStreamOnComplete: Boolean);

var

FS: TFileStream;

begin

try

   { Convert UNIX style filenames to WINDOWS style }

   while Pos('/', Filename) <> 0 do

     Filename[Pos('/', Filename)] := '\';

   { Assure that the filename DOES NOT CONTAIN any path information }

   Filename := ExtractFileName(Filename);

   { Open file in WRITE ONLY mode }

   FS := TFileStream.Create(TFTPPath + Filename,

     fmCreate or fmShareExclusive);

   { Copy all the data }

   AStream := FS;

   { Set parameters }

   FreeStreamOnComplete := True;

   GrantAccess := True;

except

   { On errors, deny access }

   GrantAccess := False;

   if Assigned(FS) then

     FreeAndNil(FS);

end;

end;

 

procedure TForm1.IdTrivialFTPServer1TransferComplete(Sender: TObject;

const Success: Boolean; const PeerInfo: TPeerInfo; AStream: TStream;

const WriteOperation: Boolean);

begin

// Success = TRUE if the read/write operation was successfull

// WriteOperation = TRUE if the client SENT a file to the server

try

   { Close the FileStream }

   if Assigned(AStream) then

     FreeAndNil(AStream);

except

end;

end;

 

// Example of how to DOWNLOAD a file from the server

 

procedure TForm1.Button1Click(Sender: TObject);

var

ST: TMemoryStream;

begin

ST := TMemoryStream.Create;

IdTrivialFTP1.Get('testfile.dat', ST);

if Assigned(ST) then

begin

   ShowMessage('Filesize=' + IntToStr(ST.Size));

   FreeAndNil(ST);

end;

end;

 

// Example of how to UPLOAD a file to the server

 

procedure TForm1.Button2Click(Sender: TObject);

var

ST: TMemoryStream;

I: Integer;

S: string;

begin

{ Create stream }

ST := TMemoryStream.Create;

{ Initialize data }

S := 'This is a test file. It whould appear in the ' +

   'TFTP Server upload directory.' + #13#10;

{ Store in stream }

ST.Write(S[1], Length(S));

ST.Position := 0;

{ Send Stream to TFTP Server }

IdTrivialFTP1.Put(ST, 'textfile.txt');

{ Free Stream }

if Assigned(ST) then

   FreeAndNil(ST);

{ Show a dialog }

ShowMessage('Done!');

end;

 

end.

 

 

©Drkb::03376

Взято с Delphi Knowledge Base: http://www.baltsoft.com/