在Delphi 7開發下有強大的Indy控件，版本為9，要實作一個FTP伺服器，參考自帶的例子，發現還要寫很多函數，而且不支援中文顯示檔案清單等等。
于是，自己改進封裝了下，形成一個TFTPServer類。
源碼如下：
1 {*******************************************************}
2 { }
3 { 系統名稱 FTP伺服器類 }
4 { 版權所有 (C) http://blog.csdn.net/akof1314 }
5 { 單元名稱 FTPServer.pas }
6 { 單元功能 在Delphi 7下TIdFTPServer實作FTP伺服器 }
7 { }
8 {*******************************************************}
9 unit FTPServer;
10
11 interface
12
13 uses
14 Classes, Windows, Sysutils, IdFTPList, IdFTPServer, Idtcpserver, IdSocketHandle, Idglobal, IdHashCRC, IdStack;
15 {-------------------------------------------------------------------------------
16 功能: 自定義消息，友善與窗體進行消息傳遞
17 -------------------------------------------------------------------------------}
18 type
19 TFtpNotifyEvent = procedure (ADatetime: TDateTime;AUserIP, AEventMessage: string) of object;
20 {-------------------------------------------------------------------------------
21 功能: FTP伺服器類
22 -------------------------------------------------------------------------------}
23 type
24 TFTPServer = class
25 private
26 FUserName,FUserPassword,FBorrowDirectory: string;
27 FBorrowPort: Integer;
28 IdFTPServer: TIdFTPServer;
29 FOnFtpNotifyEvent: TFtpNotifyEvent;
30 procedure IdFTPServer1UserLogin( ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean ) ;
31 procedure IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ;
32 procedure IdFTPServer1RenameFile( ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string ) ;
33 procedure IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream ) ;
34 procedure IdFTPServer1StoreFile( ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;
35 procedure IdFTPServer1RemoveDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;
36 procedure IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;
37 procedure IdFTPServer1GetFileSize( ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64 ) ;
38 procedure IdFTPServer1DeleteFile( ASender: TIdFTPServerThread; const APathname: string ) ;
39 procedure IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;
40 procedure IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;
41 procedure IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;
42 protected
43 function TransLatePath( const APathname, homeDir: string ) : string;
44 public
45 constructor Create; reintroduce;
46 destructor Destroy; override;
47 procedure Run;
48 procedure Stop;
49 function GetBindingIP():string;
50 property UserName: string read FUserName write FUserName;
51 property UserPassword: string read FUserPassword write FUserPassword;
52 property BorrowDirectory: string read FBorrowDirectory write FBorrowDirectory;
53 property BorrowPort: Integer read FBorrowPort write FBorrowPort;
54 property OnFtpNotifyEvent: TFtpNotifyEvent read FOnFtpNotifyEvent write FOnFtpNotifyEvent;
55 end;
56
57 implementation
58
59 {-------------------------------------------------------------------------------
60 過程名: TFTPServer.Create
61 功能: 建立函數
62 參數: 無
63 傳回值: 無
64 -------------------------------------------------------------------------------}
65 constructor TFTPServer.Create;
66 begin
67 IdFTPServer := tIdFTPServer.create( nil ) ;
68 IdFTPServer.DefaultPort := 21; //預設端口号
69 IdFTPServer.AllowAnonymousLogin := False; //是否允許匿名登入
70 IdFTPServer.EmulateSystem := ftpsUNIX;
71 IdFTPServer.HelpReply.text := '幫助還未實作！';
72 IdFTPServer.OnChangeDirectory := IdFTPServer1ChangeDirectory;
73 IdFTPServer.OnGetFileSize := IdFTPServer1GetFileSize;
74 IdFTPServer.OnListDirectory := IdFTPServer1ListDirectory;
75 IdFTPServer.OnUserLogin := IdFTPServer1UserLogin;
76 IdFTPServer.OnRenameFile := IdFTPServer1RenameFile;
77 IdFTPServer.OnDeleteFile := IdFTPServer1DeleteFile;
78 IdFTPServer.OnRetrieveFile := IdFTPServer1RetrieveFile;
79 IdFTPServer.OnStoreFile := IdFTPServer1StoreFile;
80 IdFTPServer.OnMakeDirectory := IdFTPServer1MakeDirectory;
81 IdFTPServer.OnRemoveDirectory := IdFTPServer1RemoveDirectory;
82 IdFTPServer.Greeting.Text.Text := '歡迎進入FTP伺服器';
83 IdFTPServer.Greeting.NumericCode := 220;
84 IdFTPServer.OnDisconnect := IdFTPServer1DisConnect;
85 with IdFTPServer.CommandHandlers.add do
86 begin
87 Command := 'XCRC'; //可以迅速驗證所下載下傳的文檔是否和源文檔一樣
88 OnCommand := IdFTPServer1CommandXCRC;
89 end;
90 end;
91 {-------------------------------------------------------------------------------
92 過程名: CalculateCRC
93 功能: 計算CRC
94 參數: const path: string
95 傳回值: string
96 -------------------------------------------------------------------------------}
97 function CalculateCRC( const path: string ) : string;
98 var
99 f: tfilestream;
100 value: dword;
101 IdHashCRC32: TIdHashCRC32;
102 begin
103 IdHashCRC32 := nil;
104 f := nil;
105 try
106 IdHashCRC32 := TIdHashCRC32.create;
107 f := TFileStream.create( path, fmOpenRead or fmShareDenyWrite ) ;
108 value := IdHashCRC32.HashValue( f ) ;
109 result := inttohex( value, 8 ) ;
110 finally
111 f.free;
112 IdHashCRC32.free;
113 end;
114 end;
115
116 {-------------------------------------------------------------------------------
117 過程名: TFTPServer.IdFTPServer1CommandXCRC
118 功能: XCRC指令
119 參數: ASender: TIdCommand
120 傳回值: 無
121 -------------------------------------------------------------------------------}
122 procedure TFTPServer.IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;
123 // note, this is made up, and not defined in any rfc.
124 var
125 s: string;
126 begin
127 with TIdFTPServerThread( ASender.Thread ) do
128 begin
129 if Authenticated then
130 begin
131 try
132 s := ProcessPath( CurrentDir, ASender.UnparsedParams ) ;
133 s := TransLatePath( s, TIdFTPServerThread( ASender.Thread ) .HomeDir ) ;
134 ASender.Reply.SetReply( 213, CalculateCRC( s ) ) ;
135 except
136 ASender.Reply.SetReply( 500, 'file error' ) ;
137 end;
138 end;
139 end;
140 end;
141
142 {-------------------------------------------------------------------------------
143 過程名: TFTPServer.Destroy
144 功能: 析構函數
145 參數: 無
146 傳回值: 無
147 -------------------------------------------------------------------------------}
148 destructor TFTPServer.Destroy;
149 begin
150 IdFTPServer.free;
151 inherited destroy;
152 end;
153
154 function StartsWith( const str, substr: string ) : boolean;
155 begin
156 result := copy( str, 1, length( substr ) ) = substr;
157 end;
158
159 {-------------------------------------------------------------------------------
160 過程名: TFTPServer.Run
161 功能: 開啟服務
162 參數: 無
163 傳回值: 無
164 -------------------------------------------------------------------------------}
165 procedure TFTPServer.Run;
166 begin
167 IdFTPServer.DefaultPort := BorrowPort;
168 IdFTPServer.Active := True;
169 end;
170
171 {-------------------------------------------------------------------------------
172 過程名: TFTPServer.Stop
173 功能: 關閉服務
174 參數: 無
175 傳回值: 無
176 -------------------------------------------------------------------------------}
177 procedure TFTPServer.Stop;
178 begin
179 IdFTPServer.Active := False;
180 end;
181
182 {-------------------------------------------------------------------------------
183 過程名: TFTPServer.GetBindingIP
184 功能: 擷取綁定的IP位址
185 參數:
186 傳回值: string
187 -------------------------------------------------------------------------------}
188 function TFTPServer.GetBindingIP():string ;
189 begin
190 Result := GStack.LocalAddress;
191 end;
192 {-------------------------------------------------------------------------------
193 過程名: BackSlashToSlash
194 功能: 反斜杠到斜杠
195 參數: const str: string
196 傳回值: string
197 -------------------------------------------------------------------------------}
198 function BackSlashToSlash( const str: string ) : string;
199 var
200 a: dword;
201 begin
202 result := str;
203 for a := 1 to length( result ) do
204 if result[a] = '/' then
205 result[a] := '/';
206 end;
207
208 {-------------------------------------------------------------------------------
209 過程名: SlashToBackSlash
210 功能: 斜杠到反斜杠
211 參數: const str: string
212 傳回值: string
213 -------------------------------------------------------------------------------}
214 function SlashToBackSlash( const str: string ) : string;
215 var
216 a: dword;
217 begin
218 result := str;
219 for a := 1 to length( result ) do
220 if result[a] = '/' then
221 result[a] := '/';
222 end;
223
224 {-------------------------------------------------------------------------------
225 過程名: TFTPServer.TransLatePath
226 功能: 路徑名稱翻譯
227 參數: const APathname, homeDir: string
228 傳回值: string
229 -------------------------------------------------------------------------------}
230 function TFTPServer.TransLatePath( const APathname, homeDir: string ) : string;
231 var
232 tmppath: string;
233 begin
234 result := SlashToBackSlash(Utf8ToAnsi(homeDir) ) ;
235 tmppath := SlashToBackSlash( Utf8ToAnsi(APathname) ) ;
236 if homedir = '/' then
237 begin
238 result := tmppath;
239 exit;
240 end;
241
242 if length( APathname ) = 0 then
243 exit;
244 if result[length( result ) ] = '/' then
245 result := copy( result, 1, length( result ) - 1 ) ;
246 if tmppath[1] <> '/' then
247 result := result + '/';
248 result := result + tmppath;
249 end;
250
251 {-------------------------------------------------------------------------------
252 過程名: GetNewDirectory
253 功能: 得到新目錄
254 參數: old, action: string
255 傳回值: string
256 -------------------------------------------------------------------------------}
257 function GetNewDirectory( old, action: string ) : string;
258 var
259 a: integer;
260 begin
261 if action = '../' then
262 begin
263 if old = '/' then
264 begin
265 result := old;
266 exit;
267 end;
268 a := length( old ) - 1;
269 while ( old[a] <> '/' ) and ( old[a] <> '/' ) do
270 dec( a ) ;
271 result := copy( old, 1, a ) ;
272 exit;
273 end;
274 if ( action[1] = '/' ) or ( action[1] = '/' ) then
275 result := action
276 else
277 result := old + action;
278 end;
279
280 {-------------------------------------------------------------------------------
281 過程名: TFTPServer.IdFTPServer1UserLogin
282 功能: 允許伺服器執行一個用戶端連接配接的使用者帳戶身份驗證
283 參數: ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean
284 傳回值: 無
285 -------------------------------------------------------------------------------}
286 procedure TFTPServer.IdFTPServer1UserLogin( ASender: TIdFTPServerThread;
287 const AUsername, APassword: string; var AAuthenticated: Boolean ) ;
288 begin
289 AAuthenticated := ( AUsername = UserName ) and ( APassword = UserPassword ) ;
290 if not AAuthenticated then
291 exit;
292 ASender.HomeDir := AnsiToUtf8(BorrowDirectory);
293 asender.currentdir := '/';
294 if Assigned(FOnFtpNotifyEvent) then
295 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'使用者登入伺服器');
296 end;
297
298 {-------------------------------------------------------------------------------
299 過程名: TFTPServer.IdFTPServer1ListDirectory
300 功能: 允許伺服器生成格式化的目錄清單
301 參數: ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems
302 傳回值: 無
303 -------------------------------------------------------------------------------}
304 procedure TFTPServer.IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ;
305
306 procedure AddlistItem( aDirectoryListing: TIdFTPListItems; Filename: string; ItemType: TIdDirItemType; size: int64; date: tdatetime ) ;
307 var
308 listitem: TIdFTPListItem;
309 begin
310 listitem := aDirectoryListing.Add;
311 listitem.ItemType := ItemType; //表示一個檔案系統的屬性集
312 listitem.FileName := AnsiToUtf8(Filename); //名稱配置設定給目錄中的清單項,這裡防止了中文亂碼
313 listitem.OwnerName := 'anonymous';//代表了使用者擁有的檔案或目錄項的名稱
314 listitem.GroupName := 'all'; //指定組名擁有的檔案名稱或目錄條目
315 listitem.OwnerPermissions := 'rwx'; //擁有者權限，R讀W寫X執行
316 listitem.GroupPermissions := 'rwx'; //組擁有者權限
317 listitem.UserPermissions := 'rwx'; //使用者權限，基于使用者群組權限
318 listitem.Size := size;
319 listitem.ModifiedDate := date;
320 end;
321
322 var
323 f: tsearchrec;
324 a: integer;
325 begin
326 ADirectoryListing.DirectoryName := apath;
327 a := FindFirst( TransLatePath( apath, ASender.HomeDir ) + '*.*', faAnyFile, f ) ;
328 while ( a = 0 ) do
329 begin
330 if ( f.Attr and faDirectory > 0 ) then
331 AddlistItem( ADirectoryListing, f.Name, ditDirectory, f.size, FileDateToDateTime( f.Time ) )
332 else
333 AddlistItem( ADirectoryListing, f.Name, ditFile, f.size, FileDateToDateTime( f.Time ) ) ;
334 a := FindNext( f ) ;
335 end;
336
337 FindClose( f ) ;
338 end;
339
340 {-------------------------------------------------------------------------------
341 過程名: TFTPServer.IdFTPServer1RenameFile
342 功能: 允許伺服器重命名伺服器檔案系統中的檔案
343 參數: ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string
344 傳回值: 無
345 -------------------------------------------------------------------------------}
346 procedure TFTPServer.IdFTPServer1RenameFile( ASender: TIdFTPServerThread;
347 const ARenameFromFile, ARenameToFile: string ) ;
348 begin
349 try
350 if not MoveFile( pchar( TransLatePath( ARenameFromFile, ASender.HomeDir ) ) , pchar( TransLatePath( ARenameToFile, ASender.HomeDir ) ) ) then
351 RaiseLastOSError;
352 except
353 on e:Exception do
354 begin
355 if Assigned(FOnFtpNotifyEvent) then
356 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'重命名檔案[' + Utf8ToAnsi(ARenameFromFile) + ']失敗，原因是' + e.Message);
357 Exit;
358 end;
359 end;
360 if Assigned(FOnFtpNotifyEvent) then
361 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'重命名檔案[' + Utf8ToAnsi(ARenameFromFile) + ']為[' + Utf8ToAnsi(ARenameToFile) + ']');
362 end;
363
364 {-------------------------------------------------------------------------------
365 過程名: TFTPServer.IdFTPServer1RetrieveFile
366 功能: 允許從伺服器下載下傳檔案系統中的檔案
367 參數: ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream
368 傳回值: 無
369 -------------------------------------------------------------------------------}
370 procedure TFTPServer.IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread;
371 const AFilename: string; var VStream: TStream ) ;
372 begin
373 VStream := TFileStream.Create( translatepath( AFilename, ASender.HomeDir ) , fmopenread or fmShareDenyWrite ) ;
374 if Assigned(FOnFtpNotifyEvent) then
375 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'下載下傳檔案[' + Utf8ToAnsi(AFilename) + ']');
376 end;
377
378 {-------------------------------------------------------------------------------
379 過程名: TFTPServer.IdFTPServer1StoreFile
380 功能: 允許在伺服器上傳檔案系統中的檔案
381 參數: ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream
382 傳回值: 無
383 -------------------------------------------------------------------------------}
384 procedure TFTPServer.IdFTPServer1StoreFile( ASender: TIdFTPServerThread;
385 const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;
386 begin
387 if FileExists( translatepath( AFilename, ASender.HomeDir ) ) and AAppend then
388 begin
389 VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmOpenWrite or fmShareExclusive ) ;
390 VStream.Seek( 0, soFromEnd ) ;
391 end
392 else
393 VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmCreate or fmShareExclusive ) ;
394 if Assigned(FOnFtpNotifyEvent) then
395 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'上傳檔案[' + Utf8ToAnsi(AFilename) + ']');
396 end;
397
398 {-------------------------------------------------------------------------------
399 過程名: TFTPServer.IdFTPServer1RemoveDirectory
400 功能: 允許伺服器在伺服器删除檔案系統的目錄
401 參數: ASender: TIdFTPServerThread; var VDirectory: string
402 傳回值: 無
403 -------------------------------------------------------------------------------}
404 procedure TFTPServer.IdFTPServer1RemoveDirectory( ASender: TIdFTPServerThread;
405 var VDirectory: string ) ;
406 begin
407 try
408 RmDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;
409 except
410 on e:Exception do
411 begin
412 if Assigned(FOnFtpNotifyEvent) then
413 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除目錄[' + Utf8ToAnsi(VDirectory) + ']失敗，原因是' + e.Message);
414 Exit;
415 end;
416 end;
417 if Assigned(FOnFtpNotifyEvent) then
418 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除目錄[' + Utf8ToAnsi(VDirectory) + ']');
419 end;
420
421 {-------------------------------------------------------------------------------
422 過程名: TFTPServer.IdFTPServer1MakeDirectory
423 功能: 允許伺服器從伺服器中建立一個新的子目錄
424 參數: ASender: TIdFTPServerThread; var VDirectory: string
425 傳回值: 無
426 -------------------------------------------------------------------------------}
427 procedure TFTPServer.IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread;
428 var VDirectory: string ) ;
429 begin
430 try
431 MkDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;
432 except
433 on e:Exception do
434 begin
435 if Assigned(FOnFtpNotifyEvent) then
436 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'建立目錄[' + Utf8ToAnsi(VDirectory) + ']失敗，原因是' + e.Message);
437 Exit;
438 end;
439 end;
440 if Assigned(FOnFtpNotifyEvent) then
441 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'建立目錄[' + Utf8ToAnsi(VDirectory) + ']');
442 end;
443
444 {-------------------------------------------------------------------------------
445 過程名: TFTPServer.IdFTPServer1GetFileSize
446 功能: 允許伺服器檢索在伺服器檔案系統的檔案的大小
447 參數: ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64
448 傳回值: 無
449 -------------------------------------------------------------------------------}
450 procedure TFTPServer.IdFTPServer1GetFileSize( ASender: TIdFTPServerThread;
451 const AFilename: string; var VFileSize: Int64 ) ;
452 begin
453 VFileSize := FileSizeByName( TransLatePath( AFilename, ASender.HomeDir ) ) ;
454 if Assigned(FOnFtpNotifyEvent) then
455 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'擷取檔案大小');
456 end;
457
458 {-------------------------------------------------------------------------------
459 過程名: TFTPServer.IdFTPServer1DeleteFile
460 功能: 允許從伺服器中删除的檔案系統中的檔案
461 參數: ASender: TIdFTPServerThread; const APathname: string
462 傳回值: 無
463 -------------------------------------------------------------------------------}
464 procedure TFTPServer.IdFTPServer1DeleteFile( ASender: TIdFTPServerThread;
465 const APathname: string ) ;
466 begin
467 try
468 DeleteFile( pchar( TransLatePath( ASender.CurrentDir + '/' + APathname, ASender.HomeDir ) ) ) ;
469 except
470 on e:Exception do
471 begin
472 if Assigned(FOnFtpNotifyEvent) then
473 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除檔案[' + Utf8ToAnsi(APathname) + ']失敗，原因是' + e.Message);
474 Exit;
475 end;
476 end;
477 if Assigned(FOnFtpNotifyEvent) then
478 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除檔案[' + Utf8ToAnsi(APathname) + ']');
479 end;
480
481 {-------------------------------------------------------------------------------
482 過程名: TFTPServer.IdFTPServer1ChangeDirectory
483 功能: 允許伺服器選擇一個檔案系統路徑
484 參數: ASender: TIdFTPServerThread; var VDirectory: string
485 傳回值: 無
486 -------------------------------------------------------------------------------}
487 procedure TFTPServer.IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread;
488 var VDirectory: string ) ;
489 begin
490 VDirectory := GetNewDirectory( ASender.CurrentDir, VDirectory ) ;
491 if Assigned(FOnFtpNotifyEvent) then
492 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'進入目錄[' + Utf8ToAnsi(VDirectory) + ']');
493 end;
494
495 {-------------------------------------------------------------------------------
496 過程名: TFTPServer.IdFTPServer1DisConnect
497 功能: 失去網絡連接配接
498 參數: AThread: TIdPeerThread
499 傳回值: 無
500 -------------------------------------------------------------------------------}
501 procedure TFTPServer.IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;
502 begin
503 // nothing much here
504 end;
505 end. 使用工程示例：
1 unit Unit1;
2
3 interface
4
5 uses
6 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
7 Dialogs, StdCtrls, FTPServer;
8
9 type
10 TForm1 = class(TForm)
11 btn1: TButton;
12 btn2: TButton;
13 edt_BorrowDirectory: TEdit;
14 lbl1: TLabel;
15 mmo1: TMemo;
16 lbl2: TLabel;
17 edt_BorrowPort: TEdit;
18 lbl3: TLabel;
19 edt_UserName: TEdit;
20 lbl4: TLabel;
21 edt_UserPassword: TEdit;
22 procedure btn1Click(Sender: TObject);
23 procedure btn2Click(Sender: TObject);
24 procedure TFTPServer1FtpNotifyEvent(ADatetime: TDateTime;AUserIP, AEventMessage: string);
25 private
26 FFtpServer: TFTPServer;
27 public
28 { Public declarations }
29 end;
30
31 var
32 Form1: TForm1;
33
34 implementation
35
36
37
38 {$R *.dfm}
39
40 procedure TForm1.btn1Click(Sender: TObject);
41 begin
42 if not Assigned(FFtpServer) then
43 begin
44 FFtpServer := TFTPServer.Create;
45 FFtpServer.UserName := Trim(edt_UserName.Text);
46 FFtpServer.UserPassword := Trim(edt_UserPassword.Text);
47 FFtpServer.BorrowDirectory := Trim(edt_BorrowDirectory.Text);
48 FFtpServer.BorrowPort := StrToInt(Trim(edt_BorrowPort.Text));
49 FFtpServer.OnFtpNotifyEvent := TFTPServer1FtpNotifyEvent;
50 FFtpServer.Run;
51 mmo1.Lines.Add(DateTimeToStr(Now) + #32 +'FTP伺服器已開啟，本機IP位址：' + FFtpServer.GetBindingIP);
52 end;
53 end;
54
55 procedure TForm1.btn2Click(Sender: TObject);
56 begin
57 if Assigned(FFtpServer) then
58 begin
59 FFtpServer.Stop;
60 FreeAndNil(FFtpServer);
61 mmo1.Lines.Add(DateTimeToStr(Now) + #32 +'FTP伺服器已關閉');
62 end;
63 end;
64
65 procedure TForm1.TFTPServer1FtpNotifyEvent(ADatetime: TDateTime;AUserIP, AEventMessage: string);
66 begin
67 mmo1.Lines.Add(DateTimeToStr(ADatetime) + #32 + AUserIP + #32 + AEventMessage);
68 SendMessage(mmo1.Handle,WM_VSCROLL,SB_PAGEDOWN,0);
69 end;
70 end. 結果如下圖所示：
示例工程源碼下載下傳：
http://download.csdn.net/source/3236325
原部落格位址：
http://blog.csdn.net/akof1314/article/details/6371984#comments
https://www.cnblogs.com/findumars/p/6360865.html
1 {*******************************************************}
2 { }
3 { 系統名稱 FTP伺服器類 }
4 { 版權所有 (C) http://blog.csdn.net/akof1314 }
5 { 單元名稱 FTPServer.pas }
6 { 單元功能 在Delphi 7下TIdFTPServer實作FTP伺服器 }
7 { }
8 {*******************************************************}
9 unit FTPServer;
10
11 interface
12
13 uses
14 Classes, Windows, Sysutils, IdFTPList, IdFTPServer, Idtcpserver, IdSocketHandle, Idglobal, IdHashCRC, IdStack;
15 {-------------------------------------------------------------------------------
16 功能: 自定義消息，友善與窗體進行消息傳遞
17 -------------------------------------------------------------------------------}
18 type
19 TFtpNotifyEvent = procedure (ADatetime: TDateTime;AUserIP, AEventMessage: string) of object;
20 {-------------------------------------------------------------------------------
21 功能: FTP伺服器類
22 -------------------------------------------------------------------------------}
23 type
24 TFTPServer = class
25 private
26 FUserName,FUserPassword,FBorrowDirectory: string;
27 FBorrowPort: Integer;
28 IdFTPServer: TIdFTPServer;
29 FOnFtpNotifyEvent: TFtpNotifyEvent;
30 procedure IdFTPServer1UserLogin( ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean ) ;
31 procedure IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ;
32 procedure IdFTPServer1RenameFile( ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string ) ;
33 procedure IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream ) ;
34 procedure IdFTPServer1StoreFile( ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;
35 procedure IdFTPServer1RemoveDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;
36 procedure IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;
37 procedure IdFTPServer1GetFileSize( ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64 ) ;
38 procedure IdFTPServer1DeleteFile( ASender: TIdFTPServerThread; const APathname: string ) ;
39 procedure IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;
40 procedure IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;
41 procedure IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;
42 protected
43 function TransLatePath( const APathname, homeDir: string ) : string;
44 public
45 constructor Create; reintroduce;
46 destructor Destroy; override;
47 procedure Run;
48 procedure Stop;
49 function GetBindingIP():string;
50 property UserName: string read FUserName write FUserName;
51 property UserPassword: string read FUserPassword write FUserPassword;
52 property BorrowDirectory: string read FBorrowDirectory write FBorrowDirectory;
53 property BorrowPort: Integer read FBorrowPort write FBorrowPort;
54 property OnFtpNotifyEvent: TFtpNotifyEvent read FOnFtpNotifyEvent write FOnFtpNotifyEvent;
55 end;
56
57 implementation
58
59 {-------------------------------------------------------------------------------
60 過程名: TFTPServer.Create
61 功能: 建立函數
62 參數: 無
63 傳回值: 無
64 -------------------------------------------------------------------------------}
65 constructor TFTPServer.Create;
66 begin
67 IdFTPServer := tIdFTPServer.create( nil ) ;
68 IdFTPServer.DefaultPort := 21; //預設端口号
69 IdFTPServer.AllowAnonymousLogin := False; //是否允許匿名登入
70 IdFTPServer.EmulateSystem := ftpsUNIX;
71 IdFTPServer.HelpReply.text := '幫助還未實作！';
72 IdFTPServer.OnChangeDirectory := IdFTPServer1ChangeDirectory;
73 IdFTPServer.OnGetFileSize := IdFTPServer1GetFileSize;
74 IdFTPServer.OnListDirectory := IdFTPServer1ListDirectory;
75 IdFTPServer.OnUserLogin := IdFTPServer1UserLogin;
76 IdFTPServer.OnRenameFile := IdFTPServer1RenameFile;
77 IdFTPServer.OnDeleteFile := IdFTPServer1DeleteFile;
78 IdFTPServer.OnRetrieveFile := IdFTPServer1RetrieveFile;
79 IdFTPServer.OnStoreFile := IdFTPServer1StoreFile;
80 IdFTPServer.OnMakeDirectory := IdFTPServer1MakeDirectory;
81 IdFTPServer.OnRemoveDirectory := IdFTPServer1RemoveDirectory;
82 IdFTPServer.Greeting.Text.Text := '歡迎進入FTP伺服器';
83 IdFTPServer.Greeting.NumericCode := 220;
84 IdFTPServer.OnDisconnect := IdFTPServer1DisConnect;
85 with IdFTPServer.CommandHandlers.add do
86 begin
87 Command := 'XCRC'; //可以迅速驗證所下載下傳的文檔是否和源文檔一樣
88 OnCommand := IdFTPServer1CommandXCRC;
89 end;
90 end;
91 {-------------------------------------------------------------------------------
92 過程名: CalculateCRC
93 功能: 計算CRC
94 參數: const path: string
95 傳回值: string
96 -------------------------------------------------------------------------------}
97 function CalculateCRC( const path: string ) : string;
98 var
99 f: tfilestream;
100 value: dword;
101 IdHashCRC32: TIdHashCRC32;
102 begin
103 IdHashCRC32 := nil;
104 f := nil;
105 try
106 IdHashCRC32 := TIdHashCRC32.create;
107 f := TFileStream.create( path, fmOpenRead or fmShareDenyWrite ) ;
108 value := IdHashCRC32.HashValue( f ) ;
109 result := inttohex( value, 8 ) ;
110 finally
111 f.free;
112 IdHashCRC32.free;
113 end;
114 end;
115
116 {-------------------------------------------------------------------------------
117 過程名: TFTPServer.IdFTPServer1CommandXCRC
118 功能: XCRC指令
119 參數: ASender: TIdCommand
120 傳回值: 無
121 -------------------------------------------------------------------------------}
122 procedure TFTPServer.IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;
123 // note, this is made up, and not defined in any rfc.
124 var
125 s: string;
126 begin
127 with TIdFTPServerThread( ASender.Thread ) do
128 begin
129 if Authenticated then
130 begin
131 try
132 s := ProcessPath( CurrentDir, ASender.UnparsedParams ) ;
133 s := TransLatePath( s, TIdFTPServerThread( ASender.Thread ) .HomeDir ) ;
134 ASender.Reply.SetReply( 213, CalculateCRC( s ) ) ;
135 except
136 ASender.Reply.SetReply( 500, 'file error' ) ;
137 end;
138 end;
139 end;
140 end;
141
142 {-------------------------------------------------------------------------------
143 過程名: TFTPServer.Destroy
144 功能: 析構函數
145 參數: 無
146 傳回值: 無
147 -------------------------------------------------------------------------------}
148 destructor TFTPServer.Destroy;
149 begin
150 IdFTPServer.free;
151 inherited destroy;
152 end;
153
154 function StartsWith( const str, substr: string ) : boolean;
155 begin
156 result := copy( str, 1, length( substr ) ) = substr;
157 end;
158
159 {-------------------------------------------------------------------------------
160 過程名: TFTPServer.Run
161 功能: 開啟服務
162 參數: 無
163 傳回值: 無
164 -------------------------------------------------------------------------------}
165 procedure TFTPServer.Run;
166 begin
167 IdFTPServer.DefaultPort := BorrowPort;
168 IdFTPServer.Active := True;
169 end;
170
171 {-------------------------------------------------------------------------------
172 過程名: TFTPServer.Stop
173 功能: 關閉服務
174 參數: 無
175 傳回值: 無
176 -------------------------------------------------------------------------------}
177 procedure TFTPServer.Stop;
178 begin
179 IdFTPServer.Active := False;
180 end;
181
182 {-------------------------------------------------------------------------------
183 過程名: TFTPServer.GetBindingIP
184 功能: 擷取綁定的IP位址
185 參數:
186 傳回值: string
187 -------------------------------------------------------------------------------}
188 function TFTPServer.GetBindingIP():string ;
189 begin
190 Result := GStack.LocalAddress;
191 end;
192 {-------------------------------------------------------------------------------
193 過程名: BackSlashToSlash
194 功能: 反斜杠到斜杠
195 參數: const str: string
196 傳回值: string
197 -------------------------------------------------------------------------------}
198 function BackSlashToSlash( const str: string ) : string;
199 var
200 a: dword;
201 begin
202 result := str;
203 for a := 1 to length( result ) do
204 if result[a] = '/' then
205 result[a] := '/';
206 end;
207
208 {-------------------------------------------------------------------------------
209 過程名: SlashToBackSlash
210 功能: 斜杠到反斜杠
211 參數: const str: string
212 傳回值: string
213 -------------------------------------------------------------------------------}
214 function SlashToBackSlash( const str: string ) : string;
215 var
216 a: dword;
217 begin
218 result := str;
219 for a := 1 to length( result ) do
220 if result[a] = '/' then
221 result[a] := '/';
222 end;
223
224 {-------------------------------------------------------------------------------
225 過程名: TFTPServer.TransLatePath
226 功能: 路徑名稱翻譯
227 參數: const APathname, homeDir: string
228 傳回值: string
229 -------------------------------------------------------------------------------}
230 function TFTPServer.TransLatePath( const APathname, homeDir: string ) : string;
231 var
232 tmppath: string;
233 begin
234 result := SlashToBackSlash(Utf8ToAnsi(homeDir) ) ;
235 tmppath := SlashToBackSlash( Utf8ToAnsi(APathname) ) ;
236 if homedir = '/' then
237 begin
238 result := tmppath;
239 exit;
240 end;
241
242 if length( APathname ) = 0 then
243 exit;
244 if result[length( result ) ] = '/' then
245 result := copy( result, 1, length( result ) - 1 ) ;
246 if tmppath[1] <> '/' then
247 result := result + '/';
248 result := result + tmppath;
249 end;
250
251 {-------------------------------------------------------------------------------
252 過程名: GetNewDirectory
253 功能: 得到新目錄
254 參數: old, action: string
255 傳回值: string
256 -------------------------------------------------------------------------------}
257 function GetNewDirectory( old, action: string ) : string;
258 var
259 a: integer;
260 begin
261 if action = '../' then
262 begin
263 if old = '/' then
264 begin
265 result := old;
266 exit;
267 end;
268 a := length( old ) - 1;
269 while ( old[a] <> '/' ) and ( old[a] <> '/' ) do
270 dec( a ) ;
271 result := copy( old, 1, a ) ;
272 exit;
273 end;
274 if ( action[1] = '/' ) or ( action[1] = '/' ) then
275 result := action
276 else
277 result := old + action;
278 end;
279
280 {-------------------------------------------------------------------------------
281 過程名: TFTPServer.IdFTPServer1UserLogin
282 功能: 允許伺服器執行一個用戶端連接配接的使用者帳戶身份驗證
283 參數: ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean
284 傳回值: 無
285 -------------------------------------------------------------------------------}
286 procedure TFTPServer.IdFTPServer1UserLogin( ASender: TIdFTPServerThread;
287 const AUsername, APassword: string; var AAuthenticated: Boolean ) ;
288 begin
289 AAuthenticated := ( AUsername = UserName ) and ( APassword = UserPassword ) ;
290 if not AAuthenticated then
291 exit;
292 ASender.HomeDir := AnsiToUtf8(BorrowDirectory);
293 asender.currentdir := '/';
294 if Assigned(FOnFtpNotifyEvent) then
295 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'使用者登入伺服器');
296 end;
297
298 {-------------------------------------------------------------------------------
299 過程名: TFTPServer.IdFTPServer1ListDirectory
300 功能: 允許伺服器生成格式化的目錄清單
301 參數: ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems
302 傳回值: 無
303 -------------------------------------------------------------------------------}
304 procedure TFTPServer.IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ;
305
306 procedure AddlistItem( aDirectoryListing: TIdFTPListItems; Filename: string; ItemType: TIdDirItemType; size: int64; date: tdatetime ) ;
307 var
308 listitem: TIdFTPListItem;
309 begin
310 listitem := aDirectoryListing.Add;
311 listitem.ItemType := ItemType; //表示一個檔案系統的屬性集
312 listitem.FileName := AnsiToUtf8(Filename); //名稱配置設定給目錄中的清單項,這裡防止了中文亂碼
313 listitem.OwnerName := 'anonymous';//代表了使用者擁有的檔案或目錄項的名稱
314 listitem.GroupName := 'all'; //指定組名擁有的檔案名稱或目錄條目
315 listitem.OwnerPermissions := 'rwx'; //擁有者權限，R讀W寫X執行
316 listitem.GroupPermissions := 'rwx'; //組擁有者權限
317 listitem.UserPermissions := 'rwx'; //使用者權限，基于使用者群組權限
318 listitem.Size := size;
319 listitem.ModifiedDate := date;
320 end;
321
322 var
323 f: tsearchrec;
324 a: integer;
325 begin
326 ADirectoryListing.DirectoryName := apath;
327 a := FindFirst( TransLatePath( apath, ASender.HomeDir ) + '*.*', faAnyFile, f ) ;
328 while ( a = 0 ) do
329 begin
330 if ( f.Attr and faDirectory > 0 ) then
331 AddlistItem( ADirectoryListing, f.Name, ditDirectory, f.size, FileDateToDateTime( f.Time ) )
332 else
333 AddlistItem( ADirectoryListing, f.Name, ditFile, f.size, FileDateToDateTime( f.Time ) ) ;
334 a := FindNext( f ) ;
335 end;
336
337 FindClose( f ) ;
338 end;
339
340 {-------------------------------------------------------------------------------
341 過程名: TFTPServer.IdFTPServer1RenameFile
342 功能: 允許伺服器重命名伺服器檔案系統中的檔案
343 參數: ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string
344 傳回值: 無
345 -------------------------------------------------------------------------------}
346 procedure TFTPServer.IdFTPServer1RenameFile( ASender: TIdFTPServerThread;
347 const ARenameFromFile, ARenameToFile: string ) ;
348 begin
349 try
350 if not MoveFile( pchar( TransLatePath( ARenameFromFile, ASender.HomeDir ) ) , pchar( TransLatePath( ARenameToFile, ASender.HomeDir ) ) ) then
351 RaiseLastOSError;
352 except
353 on e:Exception do
354 begin
355 if Assigned(FOnFtpNotifyEvent) then
356 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'重命名檔案[' + Utf8ToAnsi(ARenameFromFile) + ']失敗，原因是' + e.Message);
357 Exit;
358 end;
359 end;
360 if Assigned(FOnFtpNotifyEvent) then
361 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'重命名檔案[' + Utf8ToAnsi(ARenameFromFile) + ']為[' + Utf8ToAnsi(ARenameToFile) + ']');
362 end;
363
364 {-------------------------------------------------------------------------------
365 過程名: TFTPServer.IdFTPServer1RetrieveFile
366 功能: 允許從伺服器下載下傳檔案系統中的檔案
367 參數: ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream
368 傳回值: 無
369 -------------------------------------------------------------------------------}
370 procedure TFTPServer.IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread;
371 const AFilename: string; var VStream: TStream ) ;
372 begin
373 VStream := TFileStream.Create( translatepath( AFilename, ASender.HomeDir ) , fmopenread or fmShareDenyWrite ) ;
374 if Assigned(FOnFtpNotifyEvent) then
375 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'下載下傳檔案[' + Utf8ToAnsi(AFilename) + ']');
376 end;
377
378 {-------------------------------------------------------------------------------
379 過程名: TFTPServer.IdFTPServer1StoreFile
380 功能: 允許在伺服器上傳檔案系統中的檔案
381 參數: ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream
382 傳回值: 無
383 -------------------------------------------------------------------------------}
384 procedure TFTPServer.IdFTPServer1StoreFile( ASender: TIdFTPServerThread;
385 const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;
386 begin
387 if FileExists( translatepath( AFilename, ASender.HomeDir ) ) and AAppend then
388 begin
389 VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmOpenWrite or fmShareExclusive ) ;
390 VStream.Seek( 0, soFromEnd ) ;
391 end
392 else
393 VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmCreate or fmShareExclusive ) ;
394 if Assigned(FOnFtpNotifyEvent) then
395 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'上傳檔案[' + Utf8ToAnsi(AFilename) + ']');
396 end;
397
398 {-------------------------------------------------------------------------------
399 過程名: TFTPServer.IdFTPServer1RemoveDirectory
400 功能: 允許伺服器在伺服器删除檔案系統的目錄
401 參數: ASender: TIdFTPServerThread; var VDirectory: string
402 傳回值: 無
403 -------------------------------------------------------------------------------}
404 procedure TFTPServer.IdFTPServer1RemoveDirectory( ASender: TIdFTPServerThread;
405 var VDirectory: string ) ;
406 begin
407 try
408 RmDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;
409 except
410 on e:Exception do
411 begin
412 if Assigned(FOnFtpNotifyEvent) then
413 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除目錄[' + Utf8ToAnsi(VDirectory) + ']失敗，原因是' + e.Message);
414 Exit;
415 end;
416 end;
417 if Assigned(FOnFtpNotifyEvent) then
418 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除目錄[' + Utf8ToAnsi(VDirectory) + ']');
419 end;
420
421 {-------------------------------------------------------------------------------
422 過程名: TFTPServer.IdFTPServer1MakeDirectory
423 功能: 允許伺服器從伺服器中建立一個新的子目錄
424 參數: ASender: TIdFTPServerThread; var VDirectory: string
425 傳回值: 無
426 -------------------------------------------------------------------------------}
427 procedure TFTPServer.IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread;
428 var VDirectory: string ) ;
429 begin
430 try
431 MkDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;
432 except
433 on e:Exception do
434 begin
435 if Assigned(FOnFtpNotifyEvent) then
436 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'建立目錄[' + Utf8ToAnsi(VDirectory) + ']失敗，原因是' + e.Message);
437 Exit;
438 end;
439 end;
440 if Assigned(FOnFtpNotifyEvent) then
441 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'建立目錄[' + Utf8ToAnsi(VDirectory) + ']');
442 end;
443
444 {-------------------------------------------------------------------------------
445 過程名: TFTPServer.IdFTPServer1GetFileSize
446 功能: 允許伺服器檢索在伺服器檔案系統的檔案的大小
447 參數: ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64
448 傳回值: 無
449 -------------------------------------------------------------------------------}
450 procedure TFTPServer.IdFTPServer1GetFileSize( ASender: TIdFTPServerThread;
451 const AFilename: string; var VFileSize: Int64 ) ;
452 begin
453 VFileSize := FileSizeByName( TransLatePath( AFilename, ASender.HomeDir ) ) ;
454 if Assigned(FOnFtpNotifyEvent) then
455 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'擷取檔案大小');
456 end;
457
458 {-------------------------------------------------------------------------------
459 過程名: TFTPServer.IdFTPServer1DeleteFile
460 功能: 允許從伺服器中删除的檔案系統中的檔案
461 參數: ASender: TIdFTPServerThread; const APathname: string
462 傳回值: 無
463 -------------------------------------------------------------------------------}
464 procedure TFTPServer.IdFTPServer1DeleteFile( ASender: TIdFTPServerThread;
465 const APathname: string ) ;
466 begin
467 try
468 DeleteFile( pchar( TransLatePath( ASender.CurrentDir + '/' + APathname, ASender.HomeDir ) ) ) ;
469 except
470 on e:Exception do
471 begin
472 if Assigned(FOnFtpNotifyEvent) then
473 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除檔案[' + Utf8ToAnsi(APathname) + ']失敗，原因是' + e.Message);
474 Exit;
475 end;
476 end;
477 if Assigned(FOnFtpNotifyEvent) then
478 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除檔案[' + Utf8ToAnsi(APathname) + ']');
479 end;
480
481 {-------------------------------------------------------------------------------
482 過程名: TFTPServer.IdFTPServer1ChangeDirectory
483 功能: 允許伺服器選擇一個檔案系統路徑
484 參數: ASender: TIdFTPServerThread; var VDirectory: string
485 傳回值: 無
486 -------------------------------------------------------------------------------}
487 procedure TFTPServer.IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread;
488 var VDirectory: string ) ;
489 begin
490 VDirectory := GetNewDirectory( ASender.CurrentDir, VDirectory ) ;
491 if Assigned(FOnFtpNotifyEvent) then
492 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'進入目錄[' + Utf8ToAnsi(VDirectory) + ']');
493 end;
494
495 {-------------------------------------------------------------------------------
496 過程名: TFTPServer.IdFTPServer1DisConnect
497 功能: 失去網絡連接配接
498 參數: AThread: TIdPeerThread
499 傳回值: 無
500 -------------------------------------------------------------------------------}
501 procedure TFTPServer.IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;
502 begin
503 // nothing much here
504 end;
505 end. 1 unit Unit1;
2
3 interface
4
5 uses
6 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
7 Dialogs, StdCtrls, FTPServer;
8
9 type
10 TForm1 = class(TForm)
11 btn1: TButton;
12 btn2: TButton;
13 edt_BorrowDirectory: TEdit;
14 lbl1: TLabel;
15 mmo1: TMemo;
16 lbl2: TLabel;
17 edt_BorrowPort: TEdit;
18 lbl3: TLabel;
19 edt_UserName: TEdit;
20 lbl4: TLabel;
21 edt_UserPassword: TEdit;
22 procedure btn1Click(Sender: TObject);
23 procedure btn2Click(Sender: TObject);
24 procedure TFTPServer1FtpNotifyEvent(ADatetime: TDateTime;AUserIP, AEventMessage: string);
25 private
26 FFtpServer: TFTPServer;
27 public
28 { Public declarations }
29 end;
30
31 var
32 Form1: TForm1;
33
34 implementation
35
36
37
38 {$R *.dfm}
39
40 procedure TForm1.btn1Click(Sender: TObject);
41 begin
42 if not Assigned(FFtpServer) then
43 begin
44 FFtpServer := TFTPServer.Create;
45 FFtpServer.UserName := Trim(edt_UserName.Text);
46 FFtpServer.UserPassword := Trim(edt_UserPassword.Text);
47 FFtpServer.BorrowDirectory := Trim(edt_BorrowDirectory.Text);
48 FFtpServer.BorrowPort := StrToInt(Trim(edt_BorrowPort.Text));
49 FFtpServer.OnFtpNotifyEvent := TFTPServer1FtpNotifyEvent;
50 FFtpServer.Run;
51 mmo1.Lines.Add(DateTimeToStr(Now) + #32 +'FTP伺服器已開啟，本機IP位址：' + FFtpServer.GetBindingIP);
52 end;
53 end;
54
55 procedure TForm1.btn2Click(Sender: TObject);
56 begin
57 if Assigned(FFtpServer) then
58 begin
59 FFtpServer.Stop;
60 FreeAndNil(FFtpServer);
61 mmo1.Lines.Add(DateTimeToStr(Now) + #32 +'FTP伺服器已關閉');
62 end;
63 end;
64
65 procedure TForm1.TFTPServer1FtpNotifyEvent(ADatetime: TDateTime;AUserIP, AEventMessage: string);
66 begin
67 mmo1.Lines.Add(DateTimeToStr(ADatetime) + #32 + AUserIP + #32 + AEventMessage);
68 SendMessage(mmo1.Handle,WM_VSCROLL,SB_PAGEDOWN,0);
69 end;
70 end. ![極其無聊的 StrtoDate 失敗[圖]](data:image/gif;base64,R0lGODlhAQABAIAAAP///wAAACwAAAAAAQABAAACAkQBADs=)