I am trying to get an answer to the same issue for the last 3 weeks, I am looking for sample code (that can be
compiled) to setup a simple TFTP or FTP server
function CorrectFTPPath(s: string): string;
begin
S := StringReplace(S, '//', '\', [rfReplaceAll]);
S := StringReplace(S, '/', '\', [rfReplaceAll]);
if ( (S <> '') and (S[1] <> '\') ) then
S := '\' + S;
result := s;
end;
procedure TfFTPServerMain.IdFTPServer1ListDirectory(ASender: TIdFTPServerThread;
const APath: String; ADirectoryListing: TIdFTPListItems);
var
newitem: TIdFTPListItem;
SearchRec: TSearchRec;
SearchResult: integer;
SearchPath: string;
begin
AddToLog(ASender.Connection.Socket.Binding.PeerIP + ' - LIST ' + APath);
SearchPath := CorrectFTPPath(APath);
ADirectoryListing.ListFormat := flfDos;
SearchResult := FindFirst(SearchPath + '*.*', faAnyFile, SearchRec);
while SearchResult = 0 do
begin
if (SearchRec.Attr and faDirectory) = faDirectory then
begin
newitem := ADirectoryListing.Add;
newitem.FileName := SearchRec.Name;
newitem.ItemType := ditDirectory;
newitem.Size := SearchRec.Size;
newitem.ModifiedDate := SearchRec.Time;
end
else
begin
newitem := ADirectoryListing.Add;
newitem.FileName := SearchRec.Name;
newitem.ItemType := ditFile;
newitem.Size := SearchRec.Size;
newitem.ModifiedDate := SearchRec.Time;
end;
SearchResult := FindNext(SearchRec);
end;
FindClose(SearchRec);
end;
procedure TfFTPServerMain.bStartStopServerClick(Sender: TObject);
begin
IdFTPServer1.Active := (not IdFTPServer1.Active);
if IdFTPServer1.Active then
begin
bStartStopServer.caption := 'Stop Server';
AddToLog('Started FTP Server');
end
else
begin
bStartStopServer.caption := 'Start Server';
AddToLog('Stopped FTP Server');
end;
end;
procedure TfFTPServerMain.IdFTPServer1UserLogin(ASender: TIdFTPServerThread;
const AUsername, APassword: String; var AAuthenticated: Boolean);
begin
// # Note - do any user authentication here (read user from ini file etc)
if ( (AUserName = 'ftp') and (APassword = 'ftp') ) then
AAuthenticated := true;
I have tried using the ICS ftpserver smaple however, when I bring the sample up, the first thing I get is TftpServer calss can't be found. how do I continue ?
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
IdBaseComponent, IdComponent, IdTCPServer, IdFTPList, IdFTPServer,
StdCtrls, scktcomp;
type
TfFTPServerMain = class(TForm)
IdFTPServer1: TIdFTPServer;
bStartStopServer: TButton;
mLog: TMemo;
procedure IdFTPServer1ListDirectory(
const APath: String; ADirectoryListing: TIdFTPListItems);
procedure bStartStopServerClick(Send
procedure IdFTPServer1UserLogin(ASen
const AUsername, APassword: String; var AAuthenticated: Boolean);
procedure IdFTPServer1ChangeDirector
var VDirectory: String);
procedure IdFTPServer1StoreFile(ASen
const AFileName: String; AAppend: Boolean; var VStream: TStream);
procedure IdFTPServer1RetrieveFile(A
const AFileName: String; var VStream: TStream);
procedure IdFTPServer1Connect(AThrea
procedure IdFTPServer1Disconnect(ATh
private
procedure AddToLog(s: string);
{ Private declarations }
public
{ Public declarations }
end;
var
fFTPServerMain: TfFTPServerMain;
function CorrectFTPPath(s: string): string;
IMPLEMENTATION
(* }-=Loki=-{ lokiwashere@yahoo.co.nz *)
{$R *.DFM}
function CorrectFTPPath(s: string): string;
begin
S := StringReplace(S, '//', '\', [rfReplaceAll]);
S := StringReplace(S, '/', '\', [rfReplaceAll]);
if ( (S <> '') and (S[1] <> '\') ) then
S := '\' + S;
result := s;
end;
procedure TfFTPServerMain.IdFTPServe
const APath: String; ADirectoryListing: TIdFTPListItems);
var
newitem: TIdFTPListItem;
SearchRec: TSearchRec;
SearchResult: integer;
SearchPath: string;
begin
AddToLog(ASender.Connectio
SearchPath := CorrectFTPPath(APath);
ADirectoryListing.ListForm
SearchResult := FindFirst(SearchPath + '*.*', faAnyFile, SearchRec);
while SearchResult = 0 do
begin
if (SearchRec.Attr and faDirectory) = faDirectory then
begin
newitem := ADirectoryListing.Add;
newitem.FileName := SearchRec.Name;
newitem.ItemType := ditDirectory;
newitem.Size := SearchRec.Size;
newitem.ModifiedDate := SearchRec.Time;
end
else
begin
newitem := ADirectoryListing.Add;
newitem.FileName := SearchRec.Name;
newitem.ItemType := ditFile;
newitem.Size := SearchRec.Size;
newitem.ModifiedDate := SearchRec.Time;
end;
SearchResult := FindNext(SearchRec);
end;
FindClose(SearchRec);
end;
procedure TfFTPServerMain.bStartStop
begin
IdFTPServer1.Active := (not IdFTPServer1.Active);
if IdFTPServer1.Active then
begin
bStartStopServer.caption := 'Stop Server';
AddToLog('Started FTP Server');
end
else
begin
bStartStopServer.caption := 'Start Server';
AddToLog('Stopped FTP Server');
end;
end;
procedure TfFTPServerMain.IdFTPServe
const AUsername, APassword: String; var AAuthenticated: Boolean);
begin
// # Note - do any user authentication here (read user from ini file etc)
if ( (AUserName = 'ftp') and (APassword = 'ftp') ) then
AAuthenticated := true;
if AAuthenticated then
AddToLog(ASender.Connectio
else
AddToLog(ASender.Connectio
end;
procedure TfFTPServerMain.IdFTPServe
var VDirectory: String);
begin
AddToLog(ASender.Connectio
VDirectory := StringReplace(VDirectory, '/', '\', [rfReplaceAll]);
end;
procedure TfFTPServerMain.IdFTPServe
const AFileName: String; AAppend: Boolean; var VStream: TStream);
var
ActualFilename: string;
begin
AddToLog(ASender.Connectio
ActualFilename := CorrectFTPPath(AFilename);
VStream := TFileStream.Create(ActualF
end;
procedure TfFTPServerMain.IdFTPServe
const AFileName: String; var VStream: TStream);
var
ActualFilename: string;
begin
AddToLog(ASender.Connectio
ActualFilename := CorrectFTPPath(AFilename);
if FileExists(ActualFilename)
VStream := TFileStream.Create(ActualF
end;
procedure TfFTPServerMain.IdFTPServe
begin
AddToLog(AThread.Connectio
end;
procedure TfFTPServerMain.IdFTPServe
begin
if assigned(AThread.Connectio
AddToLog(AThread.Connectio
else
AddToLog('Remote client disconnected')
end;
procedure TfFTPServerMain.AddToLog(s
begin
mLog.Lines.Add(FormatDateT
mLog.Perform(EM_SCROLL,SB_
while mLog.Lines.Count > 500 do mLog.Lines.Delete(0);
end;
end.
// FORM FOLLOWS
object fFTPServerMain: TfFTPServerMain
Left = 247
Top = 230
Width = 575
Height = 391
Caption = '}=-Loki=-{ FTP Server example (lokiwashere@yahoo.co.nz)'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object bStartStopServer: TButton
Left = 8
Top = 8
Width = 75
Height = 25
Caption = 'Start Server'
TabOrder = 0
OnClick = bStartStopServerClick
end
object mLog: TMemo
Left = 8
Top = 48
Width = 537
Height = 297
ScrollBars = ssBoth
TabOrder = 1
end
object IdFTPServer1: TIdFTPServer
Bindings = <>
CommandHandlers = <>
DefaultPort = 21
Greeting.NumericCode = 220
Greeting.Text.Strings = (
'Indy FTP Server ready.')
Greeting.TextCode = '220'
MaxConnectionReply.Numeric
OnConnect = IdFTPServer1Connect
OnDisconnect = IdFTPServer1Disconnect
ReplyExceptionCode = 0
ReplyTexts = <>
ReplyUnknownCommand.Numeri
ReplyUnknownCommand.Text.S
'Syntax error, command unrecognized.')
ReplyUnknownCommand.TextCo
AnonymousAccounts.Strings = (
'anonymous'
'ftp'
'guest')
EmulateSystem = ftpsOther
SystemType = 'WIN32'
OnChangeDirectory = IdFTPServer1ChangeDirector
OnUserLogin = IdFTPServer1UserLogin
OnListDirectory = IdFTPServer1ListDirectory
OnRetrieveFile = IdFTPServer1RetrieveFile
OnStoreFile = IdFTPServer1StoreFile
Left = 384
Top = 24
end
end