那位高手能详细介绍一下delphi的idftpserver控件使用方法。 那位高手能详细介绍一下delphi的idftpserver控件使用方法。特别是如何设置用户账号、密码。与其权限……谢谢大家了~~~ 解决方案 » 免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货 {$APPTYPE console}usesClasses,windows,sysutils,IdFTPList,IdFTPServer,idtcpserver,IdSocketHandle,idglobal,IdHashCRC;typeTFTPServer = classprivate{ Private declarations }IdFTPServer: tIdFTPServer;procedure IdFTPServer1UserLogin( ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean ) ;procedure IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ;procedure IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream ) ;procedure IdFTPServer1StoreFile( ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;procedure IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;// procedure IdFTPServer1GetFileSize( ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64 ) ;procedure IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;// procedure IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;// procedure IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;protectedfunction TransLatePath( const APathname, homeDir: string ) : string;publicconstructor Create; reintroduce;destructor Destroy; override;end;constructor TFTPServer.Create;beginIdFTPServer := tIdFTPServer.create( nil ) ;IdFTPServer.DefaultPort := 21;IdFTPServer.AllowAnonymousLogin := False;IdFTPServer.EmulateSystem := ftpsUNIX;IdFTPServer.HelpReply.text := '帮助还没实现';IdFTPServer.OnChangeDirectory := IdFTPServer1ChangeDirectory;IdFTPServer.OnChangeDirectory := IdFTPServer1ChangeDirectory;// IdFTPServer.OnGetFileSize := IdFTPServer1GetFileSize;IdFTPServer.OnListDirectory := IdFTPServer1ListDirectory;IdFTPServer.OnUserLogin := IdFTPServer1UserLogin;IdFTPServer.OnRetrieveFile := IdFTPServer1RetrieveFile;IdFTPServer.OnStoreFile := IdFTPServer1StoreFile;IdFTPServer.OnMakeDirectory := IdFTPServer1MakeDirectory;IdFTPServer.Greeting.Text.Text := '欢迎进入FTP服务器! ';IdFTPServer.Greeting.NumericCode := 220;// IdFTPServer.OnDisconnect := IdFTPServer1DisConnect;// with IdFTPServer.CommandHandlers.add do// begin// Command := 'XCRC';// OnCommand := IdFTPServer1CommandXCRC;// end;IdFTPServer.Active := true;end;{function CalculateCRC( const path: string ) : string;varf: tfilestream;value: dword;IdHashCRC32: TIdHashCRC32;beginIdHashCRC32 := nil;f := nil;tryIdHashCRC32 := TIdHashCRC32.create;f := TFileStream.create( path, fmOpenRead or fmShareDenyWrite ) ;value := IdHashCRC32.HashValue( f ) ;result := inttohex( value, 8 ) ;finallyf.free;IdHashCRC32.free;end;end;procedure TFTPServer.IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;// note, this is made up, and not defined in any rfc.vars: string;beginwith TIdFTPServerThread( ASender.Thread ) dobeginif Authenticated thenbegintrys := ProcessPath( CurrentDir, ASender.UnparsedParams ) ;s := TransLatePath( s, TIdFTPServerThread( ASender.Thread ) .HomeDir ) ;ASender.Reply.SetReply( 213, CalculateCRC( s ) ) ;exceptASender.Reply.SetReply( 500, 'file error' ) ;end;end;end;end;}destructor TFTPServer.Destroy;beginIdFTPServer.free;inherited destroy;end;function StartsWith( const str, substr: string ) : boolean;beginresult := copy( str, 1, length( substr ) ) = substr;end;function BackSlashToSlash( const str: string ) : string;vara: dword;beginresult := str;for a := 1 to length( result ) doif result[a] = '\' thenresult[a] := '/';end;function SlashToBackSlash( const str: string ) : string;vara: dword;beginresult := str;for a := 1 to length( result ) doif result[a] = '/' thenresult[a] := '\';end;function TFTPServer.TransLatePath( const APathname, homeDir: string ) : string;vartmppath: string;beginresult := SlashToBackSlash( homeDir ) ;tmppath := SlashToBackSlash( APathname ) ;if homedir = '/' thenbeginresult := tmppath;exit;end;if length( APathname ) = 0 thenexit;if result[length( result ) ] = '\' thenresult := copy( result, 1, length( result ) - 1 ) ;if tmppath[1] <> '\' thenresult := result + '\';result := result + tmppath;end;{function GetSizeOfFile( const APathname: string ) : int64;beginresult := FileSizeByName( APathname ) ;end;}function GetNewDirectory( old, action: string ) : string;vara: integer;beginif action = '../' thenbeginif old = '/' thenbeginresult := old;exit;end;a := length( old ) - 1;while ( old[a] <> '\' ) and ( old[a] <> '/' ) dodec( a ) ;result := copy( old, 1, a ) ;exit;end;if ( action[1] = '/' ) or ( action[1] = '\' ) thenresult := actionelseresult := old + action;end;procedure TFTPServer.IdFTPServer1UserLogin( ASender: TIdFTPServerThread;const AUsername, APassword: string; var AAuthenticated: Boolean ) ;beginAAuthenticated := ( AUsername = 'wjh' ) and ( APassword = 'jhw' ) ;if not AAuthenticated thenexit;ASender.HomeDir := './';asender.currentdir := '/';end;procedure TFTPServer.IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ;procedure AddlistItem( aDirectoryListing: TIdFTPListItems; Filename: string; ItemType: TIdDirItemType; size: int64; date: tdatetime ) ;varlistitem: TIdFTPListItem;beginlistitem := aDirectoryListing.Add;listitem.ItemType := ItemType;listitem.FileName := Filename;listitem.OwnerName := 'anonymous';listitem.GroupName := 'all';listitem.OwnerPermissions := 'rwx';listitem.GroupPermissions := 'rwx';listitem.UserPermissions := 'rwx';listitem.Size := size;listitem.ModifiedDate := date;end;varf: tsearchrec;a: integer;beginADirectoryListing.DirectoryName := APath;a := FindFirst( TransLatePath( APath, ASender.HomeDir ) + '*.*', faAnyFile, f ) ;while ( a = 0 ) dobeginif ( f.Attr and faDirectory > 0 ) thenAddlistItem( ADirectoryListing, f.Name, ditDirectory, f.size, FileDateToDateTime( f.Time ) )elseAddlistItem( ADirectoryListing, f.Name, ditFile, f.size, FileDateToDateTime( f.Time ) ) ;a := FindNext( f ) ;end;FindClose( f ) ;end;procedure TFTPServer.IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread;const AFilename: string; var VStream: TStream ) ;beginVStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmopenread or fmShareDenyWrite ) ;end;procedure TFTPServer.IdFTPServer1StoreFile( ASender: TIdFTPServerThread;const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;beginif FileExists( translatepath( AFilename, ASender.HomeDir ) ) and AAppend thenbeginVStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmOpenWrite or fmShareExclusive ) ;VStream.Seek( 0, soFromEnd ) ;endelseVStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmCreate or fmShareExclusive ) ;end;procedure TFTPServer.IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread;var VDirectory: string ) ;beginMkDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;end;{procedure TFTPServer.IdFTPServer1GetFileSize( ASender: TIdFTPServerThread;const AFilename: string; var VFileSize: Int64 ) ;begin// VFileSize := GetSizeOfFile( TransLatePath( AFilename, ASender.HomeDir ) ) ;end; }procedure TFTPServer.IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread;var VDirectory: string ) ;beginVDirectory := GetNewDirectory( ASender.CurrentDir, VDirectory ) ;end;{procedure TFTPServer.IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;begin// nothing much hereend;}beginwith TFTPServer.Create dotrywriteln( '程序正在运行, 按 [enter]键退出。' ) ;readlnfinallyfree;end;end. delphi2007串口控件的问题 高分求助关于"Access violation at address 69746341.Read of address 69746341" 怎样实现关自动关闭其他程序的弹出窗口??? 请SuanAddMiao(算苗)进来接分。(第一百) 用流来传递数据库资料 怎样让RAVE只打印当前纪录 DBChart一个小问题 求教!delphi如何对ppt进行编辑… 救我吧!请您抽出一点时间来看看我的问题,拜托了! DELPHI有没有中文版 关于线程和缓冲区的 类的存储结构
uses
Classes,
windows,
sysutils,
IdFTPList,
IdFTPServer,
idtcpserver,
IdSocketHandle,
idglobal,
IdHashCRC;type
TFTPServer = class
private
{ Private declarations }
IdFTPServer: tIdFTPServer;
procedure IdFTPServer1UserLogin( ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean ) ;
procedure IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ;
procedure IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream ) ;
procedure IdFTPServer1StoreFile( ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;
procedure IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;
// procedure IdFTPServer1GetFileSize( ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64 ) ;
procedure IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;
// procedure IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;
// procedure IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;
protected
function TransLatePath( const APathname, homeDir: string ) : string;
public
constructor Create; reintroduce;
destructor Destroy; override;
end;
constructor TFTPServer.Create;
begin
IdFTPServer := tIdFTPServer.create( nil ) ;
IdFTPServer.DefaultPort := 21;
IdFTPServer.AllowAnonymousLogin := False;
IdFTPServer.EmulateSystem := ftpsUNIX;
IdFTPServer.HelpReply.text := '帮助还没实现';
IdFTPServer.OnChangeDirectory := IdFTPServer1ChangeDirectory;
IdFTPServer.OnChangeDirectory := IdFTPServer1ChangeDirectory;
// IdFTPServer.OnGetFileSize := IdFTPServer1GetFileSize;
IdFTPServer.OnListDirectory := IdFTPServer1ListDirectory;
IdFTPServer.OnUserLogin := IdFTPServer1UserLogin;
IdFTPServer.OnRetrieveFile := IdFTPServer1RetrieveFile;
IdFTPServer.OnStoreFile := IdFTPServer1StoreFile;
IdFTPServer.OnMakeDirectory := IdFTPServer1MakeDirectory;
IdFTPServer.Greeting.Text.Text := '欢迎进入FTP服务器! ';
IdFTPServer.Greeting.NumericCode := 220;
// IdFTPServer.OnDisconnect := IdFTPServer1DisConnect;
// with IdFTPServer.CommandHandlers.add do
// begin
// Command := 'XCRC';
// OnCommand := IdFTPServer1CommandXCRC;
// end;
IdFTPServer.Active := true;
end;
{
function CalculateCRC( const path: string ) : string;
var
f: tfilestream;
value: dword;
IdHashCRC32: TIdHashCRC32;
begin
IdHashCRC32 := nil;
f := nil;
try
IdHashCRC32 := TIdHashCRC32.create;
f := TFileStream.create( path, fmOpenRead or fmShareDenyWrite ) ;
value := IdHashCRC32.HashValue( f ) ;
result := inttohex( value, 8 ) ;
finally
f.free;
IdHashCRC32.free;
end;
end;procedure TFTPServer.IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;
// note, this is made up, and not defined in any rfc.
var
s: string;
begin
with TIdFTPServerThread( ASender.Thread ) do
begin
if Authenticated then
begin
try
s := ProcessPath( CurrentDir, ASender.UnparsedParams ) ;
s := TransLatePath( s, TIdFTPServerThread( ASender.Thread ) .HomeDir ) ;
ASender.Reply.SetReply( 213, CalculateCRC( s ) ) ;
except
ASender.Reply.SetReply( 500, 'file error' ) ;
end;
end;
end;
end;
}
destructor TFTPServer.Destroy;
begin
IdFTPServer.free;
inherited destroy;
end;function StartsWith( const str, substr: string ) : boolean;
begin
result := copy( str, 1, length( substr ) ) = substr;
end;function BackSlashToSlash( const str: string ) : string;
var
a: dword;
begin
result := str;
for a := 1 to length( result ) do
if result[a] = '\' then
result[a] := '/';
end;function SlashToBackSlash( const str: string ) : string;
var
a: dword;
begin
result := str;
for a := 1 to length( result ) do
if result[a] = '/' then
result[a] := '\';
end;function TFTPServer.TransLatePath( const APathname, homeDir: string ) : string;
var
tmppath: string;
begin
result := SlashToBackSlash( homeDir ) ;
tmppath := SlashToBackSlash( APathname ) ;
if homedir = '/' then
begin
result := tmppath;
exit;
end;if length( APathname ) = 0 then
exit;
if result[length( result ) ] = '\' then
result := copy( result, 1, length( result ) - 1 ) ;
if tmppath[1] <> '\' then
result := result + '\';
result := result + tmppath;
end;{function GetSizeOfFile( const APathname: string ) : int64;
begin
result := FileSizeByName( APathname ) ;
end;
}
function GetNewDirectory( old, action: string ) : string;
var
a: integer;
begin
if action = '../' then
begin
if old = '/' then
begin
result := old;
exit;
end;
a := length( old ) - 1;
while ( old[a] <> '\' ) and ( old[a] <> '/' ) do
dec( a ) ;
result := copy( old, 1, a ) ;
exit;
end;
if ( action[1] = '/' ) or ( action[1] = '\' ) then
result := action
else
result := old + action;
end;procedure TFTPServer.IdFTPServer1UserLogin( ASender: TIdFTPServerThread;
const AUsername, APassword: string; var AAuthenticated: Boolean ) ;
begin
AAuthenticated := ( AUsername = 'wjh' ) and ( APassword = 'jhw' ) ;
if not AAuthenticated then
exit;
ASender.HomeDir := './';
asender.currentdir := '/';
end;procedure TFTPServer.IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ;procedure AddlistItem( aDirectoryListing: TIdFTPListItems; Filename: string; ItemType: TIdDirItemType; size: int64; date: tdatetime ) ;
var
listitem: TIdFTPListItem;
begin
listitem := aDirectoryListing.Add;
listitem.ItemType := ItemType;
listitem.FileName := Filename;
listitem.OwnerName := 'anonymous';
listitem.GroupName := 'all';
listitem.OwnerPermissions := 'rwx';
listitem.GroupPermissions := 'rwx';
listitem.UserPermissions := 'rwx';
listitem.Size := size;
listitem.ModifiedDate := date;
end;var
f: tsearchrec;
a: integer;
begin
ADirectoryListing.DirectoryName := APath;a := FindFirst( TransLatePath( APath, ASender.HomeDir ) + '*.*', faAnyFile, f ) ;
while ( a = 0 ) do
begin
if ( f.Attr and faDirectory > 0 ) then
AddlistItem( ADirectoryListing, f.Name, ditDirectory, f.size, FileDateToDateTime( f.Time ) )
else
AddlistItem( ADirectoryListing, f.Name, ditFile, f.size, FileDateToDateTime( f.Time ) ) ;
a := FindNext( f ) ;
end;FindClose( f ) ;
end;procedure TFTPServer.IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread;
const AFilename: string; var VStream: TStream ) ;
begin
VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmopenread or fmShareDenyWrite ) ;
end;procedure TFTPServer.IdFTPServer1StoreFile( ASender: TIdFTPServerThread;
const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;
begin
if FileExists( translatepath( AFilename, ASender.HomeDir ) ) and AAppend then
begin
VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmOpenWrite or fmShareExclusive ) ;
VStream.Seek( 0, soFromEnd ) ;
end
else
VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmCreate or fmShareExclusive ) ;
end;procedure TFTPServer.IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread;
var VDirectory: string ) ;
begin
MkDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;
end;{procedure TFTPServer.IdFTPServer1GetFileSize( ASender: TIdFTPServerThread;
const AFilename: string; var VFileSize: Int64 ) ;
begin
// VFileSize := GetSizeOfFile( TransLatePath( AFilename, ASender.HomeDir ) ) ;
end; }procedure TFTPServer.IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread;
var VDirectory: string ) ;
begin
VDirectory := GetNewDirectory( ASender.CurrentDir, VDirectory ) ;
end;{procedure TFTPServer.IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;
begin
// nothing much here
end;}begin
with TFTPServer.Create do
try
writeln( '程序正在运行, 按 [enter]键退出。' ) ;
readln
finally
free;
end;
end.