一个刚毕业生的苦恼。。摆脱大家帮个忙,我快哭了。 ^_^。。。。(200分)

好大一条“鱼”呀！
——不要因为得到了“鱼”而放弃学习“渔”。

谢谢房客,受益非浅

靠别人不能靠一辈子！[!]

[]悲哀！大学生！

呵，学习。

呵呵，你不哭我就告诉你。听……
好像没有听到哭声，所以就告诉你吧：）
(一个提供 FTP 同步的控件)
unit FtpSynchronize;
interface
uses
Windows, Classes, NMFtp, Forms, Sysutils, Dialogs, FileCtrl;
type
TFtpSyncOption = (soRecurse,
soOverwriteAll, // overwrite files without checking size, date, etc.
soAbortOnErrors,
soCaseInsensitive
);
TFtpSyncOptions = set of TFtpSyncOption;
TFtpSync = class;
TFtpSyncCommand = (scConnect,
scDisconnect,
scMkDir,
scChangeDir,
scListDir,
scUpload,
scRmDir,
scDelete,
scRename);
TFtpSyncFeedbackEvent = procedure(Sender: TFtpSync;
Command: TFtpSyncCommand;
const CommandParameter, StatusMessage: String) of Object;
TFtpSyncErrorEvent = procedure(Sender: TFtpSync;
Command: TFtpSyncCommand;
const CommandParameter, ErrorMessage: String) of Object;
TFtpSyncFinishedEvent = procedure(Sender: TFtpSync;
Success: Boolean) of Object;
TFtpSyncConfirmDeleteEvent = procedure(Sender: TFtpSync;
const RemotePath, RemoteFile: String;
Directory: Boolean;
var AllowDelete: Boolean) of Object;
TFtpResult = (frNone, frSuccess, frFailure);
TFtpSync = class(TThread)
private
FFTP: TNMFTP;
FLocalPath: String;
FRemotePath: String;
FAccountName: String;
FPassword: String;
FOptions: TFtpSyncOptions;
FOnBeforeCommand, FOnAfterCommand: TFtpSyncFeedbackEvent;
FPort: Integer;
FHost: String;
FBusy: Boolean;
FOnError: TFtpSyncErrorEvent;
FFTPResult: TFtpResult;
FOnFinished: TFtpSyncFinishedEvent;
FOnConfirmDelete: TFtpSyncConfirmDeleteEvent;
FCommandTimeOutSeconds: Integer;
FCommandStartTime, FCommandLastResponseTime: TDateTime;
FExcludeFiles: TStringlist;
procedure SetLocalPath(const Value: String);
procedure SetRemotePath(const Value: String);
procedure Error(Command: TFtpSyncCommand;
const CommandParameter, ErrorMessage: String);
procedure FtpOnFailure(var Handled: Boolean;
Trans_Type: TCmdType);
procedure FtpOnSuccess(Trans_Type: TCmdType);
procedure FtpOnPacketReceived(Sender: TObject);
function GetConnectionIdleTime: TDateTime;
public
constructor Create;
Destructor Destroy;
override;
procedure Execute;
override;
procedure Abort;
property Busy: Boolean read FBusy;
published
property LocalPath: String read FLocalPath write SetLocalPath;
property RemotePath: String read FRemotePath write SetRemotePath;
property Host: String read FHost write FHost;
property Port: Integer read FPort write FPort default 21;
property AccountName: String read FAccountName write FAccountName;
property Password: String read FPassword write FPassword;
property Options: TFtpSyncOptions read FOptions write FOptions default [];
property CommandTimeOutSeconds: Integer read FCommandTimeOutSeconds write FCommandTimeOutSeconds;
property OnBeforeCommand: TFtpSyncFeedbackEvent read FOnBeforeCommand write FOnBeforeCommand;
property OnAfterCommand: TFtpSyncFeedbackEvent read FOnAfterCommand write FOnAfterCommand;
property OnError: TFtpSyncErrorEvent read FOnError write FOnError;
property OnFinished: TFtpSyncFinishedEvent read FOnFinished write FOnFinished;
property OnConfirmDelete: TFtpSyncConfirmDeleteEvent read FOnConfirmDelete write FOnConfirmDelete;
property ConnectionIdleTime: TDateTime read GetConnectionIdleTime;
property ExcludeFiles: TStringlist read FExcludeFiles;
end;

implementation
{ TFtpSync }
procedure TFtpSync.Abort;
begin
try
FFTP.Abort;
except
end;

Terminate;
end;

constructor TFtpSync.Create;
begin
inherited Create(True);
// suspended thread
Priority := tpLower;
FFTP := TNMFTP.Create(Application);
FFTP.OnSuccess := FtpOnSuccess;
FFTP.OnFailure := FtpOnFailure;
FFTP.OnPacketRecvd := FtpOnPacketReceived;
CommandTimeOutSeconds := 30;
Port := 21;
FExcludeFiles := TStringList.Create;
end;

destructor TFtpSync.Destroy;
begin
FreeAndNil(FFTP);
FExcludeFiles.Free;
inherited;
end;

procedure TFtpSync.Error(Command: TFtpSyncCommand;
const CommandParameter, ErrorMessage: String);
begin
if Assigned(OnError) then
OnError(Self, Command, CommandParameter, ErrorMessage);
end;

procedure TFtpSync.Execute;
var
Success: Boolean;
CurrentLocalPath, CurrentRemotePath: String;
function ExecCommand(Command: TFtpSyncCommand;
Parameter: String = ''): Boolean;
const
ErrorMessage: array[TFtpSyncCommand] of string = (
'Unable to connect to ftp server %s',
'Error while disconnecting from ftp server %s',
'Unable to create directory "%s"',
'Unable to go to directory "%s"',
'Can''t retrieve contents of directory "%s"',
'Error while uploading file "%s"',
'Can''t delete directory "%s"',
'Can''t delete file "%s"',
'Can''t rename "%s" to "%s"'
);
BeforeCommandMessage: array[TFtpSyncCommand] of string = (
'Connecting to server %s',
'Disconnecting from server %s',
'Creating directory "%s"',
'Changing work directory to "%s"',
'Retrieving directory listing of directory "%s"',
'Uploading file "%s"',
'Deleting directory "%s"',
'Deleting file "%s"',
'Renaming "%s" to "%s"'
);
AfterCommandMessage: array[TFtpSyncCommand] of string = (
'Connected to server %s',
'Disconnected from server %s',
'Created directory "%s"',
'Work directory changed to "%s"',
'Retrieved directory listing of directory "%s"',
'Uploaded file "%s"',
'Deleted directory "%s"',
'Deleted file "%s"',
'Renamed "%s" to "%s"'
);
var
B: Boolean;
RenLocalFile, RenRemoteFile: String;
I: Integer;
begin
FFtpResult := frNone;
try
if Command = scRename then
begin
I := Pos(';', Parameter);
RenLocalFile := Trim(Copy(Parameter, 1, I - 1));
RenRemoteFile := Trim(Copy(Parameter, I + 1, MaxInt));
end
else
begin
RenLocalFile := '';
RenRemoteFile := '';
end;
case Command of
scConnect, scDisconnect: Parameter := FFtp.Host + ':' + IntToStr(FFtp.Port);
scListDir: Parameter := FFtp.CurrentDir;
end;

if Assigned(OnBeforeCommand) then
begin
if Command = scRename then
OnBeforeCommand(Self, Command, Parameter, Format(BeforeCommandMessage[Command], [RenLocalFile, RenRemoteFile]))
else
if pos('%s', BeforeCommandMessage[Command]) <> 0 then
OnBeforeCommand(Self, Command, Parameter, Format(BeforeCommandMessage[Command], [Parameter]))
else
OnBeforeCommand(Self, Command, Parameter, BeforeCommandMessage[Command]);
end;
FCommandStartTime := Now;
FCommandLastResponseTime := FCommandStartTime;
case Command of
scConnect: begin
FFTP.Connect;
FFtpResult := frSuccess;
end;
scDisconnect: begin
FFTP.Disconnect;
FFtpResult := frSuccess;
end;
scMkDir: FFTP.MakeDirectory(Parameter);
scChangeDir: FFTP.ChangeDir(Parameter);
scListDir: begin
if (Assigned(FFTP.FTPDirectoryList)) then
FFTP.FTPDirectoryList.Clear;
FFTP.List;
end;
scUpload: begin
FFtp.Upload(Parameter, StringReplace(ExtractFileName(Parameter), '/', '/', []));
end;
scRmDir: begin
B := True;
if (Assigned(OnConfirmDelete)) then
OnConfirmDelete(Self, FFtp.CurrentDir, Parameter, True, B);
if B then
FFTP.RemoveDir(Parameter);
end;
scDelete: begin
B := True;
if (Assigned(OnConfirmDelete)) then
OnConfirmDelete(Self, FFtp.CurrentDir, Parameter, False, B);
if B then
FFtp.Delete(Parameter);
end;
scRename: begin
FFTP.Rename(RenLocalFile, RenRemoteFile);
end;
else
Raise Exception.Create('bug: unknown ftp command in ExecCommand');
end;
while FFtpResult = frNone do
begin
Sleep(0);
if Terminated then
begin
Error(Command, Parameter, 'Operation aborted.');
FFtpResult := frFailure;
FFtp.Abort;
end;
if ((Now - FCommandLastResponseTime) * SecsPerDay) > CommandTimeOutSeconds then
begin
Error(Command, Parameter, 'TIMEOUT - FTP Operation aborted.');
Terminate;
FFtpResult := frFailure;
FFtp.Abort;
end;
end;
except
FFtpResult := frFailure;
end;
if FFtpResult = frFailure then
begin
if Command = scRename then
Error(Command, Parameter, Format(ErrorMessage[Command], [renLocalFile, renRemoteFile]))
else
if pos('%s', ErrorMessage[Command]) <> 0 then
Error(Command, Parameter, Format(ErrorMessage[Command], [Parameter]))
else
Error(Command, Parameter, ErrorMessage[Command]);
Result := False;
end
else
begin
Result := True;
FFtpResult := frSuccess;
if Assigned(OnAfterCommand) then
begin
if Command = scRename then
OnAfterCommand(Self, Command, Parameter, Format(ErrorMessage[Command], [renLocalFile, renRemoteFile]))
else
if pos('%s', AfterCommandMessage[Command]) <> 0 then
OnAfterCommand(Self, Command, Parameter, Format(AfterCommandMessage[Command], [Parameter]))
else
OnAfterCommand(Self, Command, Parameter, AfterCommandMessage[Command]);
end;

end;
end;

procedure Recurse(Directory: String);
var
Search: TSearchRec;
OldLocalPath, OldRemotePath: String;
R, I: Integer;
Found: Boolean;
List: array of record
Name: String;
Size: Integer;
ExistsLocal: Boolean;
ExistsRemote: Boolean;
Different: Boolean;
Attr: String;
end;

// finds a local file and returns the file name in the right case
function GetLocalFileName(const Name: String): String;
var
Search: TSearchRec;
begin
if FindFirst(CurrentLocalPath + Name, faArchive + faDirectory, Search) = 0 then
begin
Result := Search.Name;
FindClose(Search);
end
else
Result := Name;
// Should never happen
end;

var
LocalFileName: String;
begin
OldLocalPath := CurrentLocalPath;
CurrentRemotePath := StringReplace(CurrentRemotePath, '/', '/', [rfReplaceAll]);
OldRemotePath := CurrentRemotePath;
CurrentLocalPath := IncludeTrailingBackslash(IncludeTrailingBackslash(CurrentLocalPath) + Directory);
if (CurrentRemotePath = '') or (CurrentRemotePath[Length(CurrentRemotePath)] <> '/') then
CurrentRemotePath := CurrentRemotePath + '/';
CurrentRemotePath := CurrentRemotePath + Directory;
try
// Change dir if neccerary:
if (Directory <> '') then
begin
if not ExecCommand(scChangeDir, CurrentRemotePath) then
begin
Terminate;
Exit;
end;
end;

// Get directory listing on ftp server:
if not ExecCommand(scListDir) then
begin
Terminate;
Exit;
end;

SetLength(List, FFTP.FTPDirectoryList.Name.Count);
for I := 0 to High(List) do
begin
with List do
begin
Name := FFTP.FTPDirectoryList.Name;
try
Size := StrToInt(FFTP.FTPDirectoryList.Size);
except
Size := -1;
end;
Attr := FFTP.FTPDirectoryList.Attribute;
Different := False;
ExistsLocal := False;
ExistsRemote := True;
end;
end;

R := FindFirst(CurrentLocalPath + '*.*', faAnyFile - faVolumeID, Search);
if R = 0 then
begin
while R = 0 do
begin
if Terminated then
Break;
Found := False;
for I := 0 to High(List) do
begin
if ((soCaseInsensitive in Options) and (AnsiCompareText(List.Name, Search.Name) = 0))
or ((not (soCaseInsensitive in Options)) and (List.Name = Search.Name)) then
begin
List.ExistsLocal := True;
List.Different := (List.Size <> Search.Size) or (soOverwriteAll in Options);
Found := True;
Break;
end;
end;
if (not Found) then
begin
SetLength(List, Length(List) + 1);
with List[High(List)] do
begin
Name := Search.Name;
Size := Search.Size;
if Search.Attr and faDirectory <> 0 then
Attr := 'drwxrw-rw-'
else
Attr := '-rwxrw-rw-';
Different := False;
ExistsLocal := True;
ExistsRemote := False;
end;
end;
if Terminated then
Exit;
R := FindNext(Search);
end;
FindClose(Search);
end;

for I := 0 to High(List) do
begin
with List do
begin
if Name[1] <> '.' then
begin
if FExcludeFiles.IndexOf(CurrentRemotePath + Name) = -1 then
begin
if (Pos('d', Attr) <> 0) then
begin
// Dir
if soRecurse in Options then
begin
if not ExistsRemote then
begin
// Create dir
if (not ExecCommand(scMkDir, Name)) and (soAbortOnErrors in Options) then
begin
Terminate;
Exit;
end;
Recurse(Name);
end
else
if not ExistsLocal then
begin
// Delete dir
Recurse(Name);
if (not ExecCommand(scRmDir, Name)) and (soAbortOnErrors in Options) then
begin
Terminate;
Exit;
end;
end
else
// Exists already
begin
if (soCaseInsensitive in Options) then
begin
LocalFileName := GetLocalFileName(Name);
if (soCaseInsensitive in Options) and (LocalFileName <> Name) then
begin
ExecCommand(scRename, Name + ';' + LocalFileName);
end;
end;
Recurse(Name);
end;
end;
end
else
begin
// File
// Adjust filename to the right case if needed:
if (soCaseInsensitive in Options) and (ExistsLocal) and (ExistsRemote) then
begin
LocalFileName := GetLocalFileName(Name);
if (LocalFileName <> Name) then
begin
ExecCommand(scRename, Name + ';' + LocalFileName);
end;
end;

if ((ExistsLocal) and (not ExistsRemote)) or (Different) then
begin
// Upload file
if( not ExecCommand(scUpload, CurrentLocalPath + Name)) and (soAbortOnErrors in Options) then
begin
Terminate;
Exit;
end;
end
else
if (not ExistsLocal) and (ExistsRemote) then
begin
// Delete file
if (not ExecCommand(scDelete, Name)) and (soAbortOnErrors in Options) then
begin
Terminate;
Exit;
end;
end;
end;
end;
end;
end;
if (Terminated) then
Exit;
end;
CurrentLocalPath := OldLocalPath;
CurrentRemotePath := OldRemotePath;
finally
if not Terminated then
begin
// Change dir if neccerary:
if (CurrentRemotePath <> '') then
begin
ExecCommand(scChangeDir, CurrentRemotePath);
end;
end;
end;
end;

begin
Success := False;
if Busy then
Exit;
if not DirectoryExists(LocalPath) then
Raise Exception.Create('Local directory "' + LocalPath + '" do
es not exist.');
FBusy := True;
try
FFTP.ParseList := True;
FFTP.Host := Host;
FFTP.Port := Port;
FFTP.UserID := AccountName;
FFTP.Password := Password;
if not ExecCommand(scConnect) then
begin
Terminate;
Exit;
end;

FFTP.Mode(MODE_IMAGE);
if Terminated then
Exit;
if not ExecCommand(scChangeDir, RemotePath) then
begin
Terminate;
Exit;
end;

if Terminated then
Exit;
CurrentLocalPath := LocalPath;
CurrentRemotePath := RemotePath;
if (CurrentRemotePath = '') or (not (CurrentRemotePath[1] in ['/', '/'])) then
CurrentRemotePath := '/' + CurrentRemotePath;
Recurse('');
if FFtpResult = frSuccess then
Success := True;
finally
if FFTP.Connected then
ExecCommand(scDisconnect);
FBusy := False;
if Assigned(OnFinished) then
OnFinished(Self, Success);
end;
end;

procedure TFtpSync.SetLocalPath(const Value: String);
begin
if not DirectoryExists(Value) then
Raise Exception.Create('Local directory "' + Value + '" do
es not exist.');
FLocalPath := Value;
end;

procedure TFtpSync.SetRemotePath(const Value: String);
begin
FRemotePath := StringReplace(Value, '/', '/', [rfReplaceAll]);
end;

procedure TFtpSync.FtpOnFailure(var Handled: Boolean;
Trans_Type: TCmdType);
begin
FFtpResult := frFailure;
Handled := True;
end;

procedure TFtpSync.FtpOnSuccess(Trans_Type: TCmdType);
begin
FFtpResult := frSuccess;
end;

procedure TFtpSync.FtpOnPacketReceived(Sender: TObject);
begin
FCommandLastResponseTime := Now;
end;

function TFtpSync.GetConnectionIdleTime: TDateTime;
begin
Result := (Now - FCommandLastResponseTime);
end;

end.

收藏！