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

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.

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

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...