1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
| unit MyThreadCopy;
interface
uses Classes, Windows, SysUtils, ExtCtrls, SyncObjs;
type
// Evènements
TEvtTerminated = procedure(Sender: TObject; Source, Destination: String) of object;
TEvtExcept = procedure(Sender: TObject; ProcedureName, Msg: String) of object;
TEvtError = procedure(Sender: TObject; Source, Destination, Msg: String) of object;
TEvtProgress = procedure(Sender: TObject; Source, Destination: String; Progress: Integer) of object;
TMyThreadCopy = class(TThread)
private
FSource : string;
FDestination : string;
FPosition : Int64;
FTimer : TTimer;
FData : Pointer;
FError : TEvtError;
FExcept : TEvtExcept;
FTerminated : TEvtTerminated;
FProgress : TEvtProgress;
FCriticalSection : TCriticalSection;
procedure SendExcept(Sender: TObject; ProcedureName, Msg: string);
protected
procedure Execute; override;
procedure OnTimer(Sender: TObject);
public
constructor Create(Source, Destination: string);
destructor Destroy; override;
property Data : Pointer read FData write FData;
property OnTerminated : TEvtTerminated read FTerminated write FTerminated;
property OnExcept : TEvtExcept read FExcept write FExcept;
property OnError : TEvtError read FError write FError;
property OnProgress : TEvtProgress read FProgress write FProgress;
end;
implementation
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
function CopyCallBack(TotalFileSize: LARGE_INTEGER; TotalBytesTransferred: LARGE_INTEGER; StreamSize: LARGE_INTEGER; StreamBytesTransferred: LARGE_INTEGER; dwStreamNumber: DWord; dwCallbackReason: DWord; hSourceFile: THandle; hDestinationFile: THandle; Position: PInt64): DWord; far; stdcall;
begin
Position^ := TotalBytesTransferred.QuadPart * 100 div TotalFileSize.QuadPart;
Result := PROGRESS_CONTINUE;
end;
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
{ TMyThreadCopy }
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
constructor TMyThreadCopy.Create(Source, Destination: string);
begin
try
inherited Create(True);
FreeOnTerminate := True;
FSource := Source;
FDestination := Destination;
FTimer := TTimer.Create(nil);
FTimer.Interval := 500;
FTimer.Enabled := True;
FTimer.OnTimer := OnTimer;
FCriticalSection := TCriticalSection.Create;
except
on E: Exception do SendExcept(Self, 'TMyThreadCopy.Create', E.Message);
end;
end;
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
destructor TMyThreadCopy.Destroy;
begin
try
FTimer.Enabled := False;
FreeAndNil(FTimer);
FreeAndNil(FCriticalSection);
inherited;
except
on E: Exception do SendExcept(Self, 'TMyThreadCopy.Destroy', E.Message);
end;
end;
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TMyThreadCopy.Execute;
var
Flag : Integer;
Retour: LongBool;
begin
inherited;
try
Flag := 0;
Retour := False;
if FileExists(FSource) then
begin
// Exécution de la copie
if not CopyFileEx(PChar(FSource), PChar(FDestination), @CopyCallBack, @FPosition, @Retour, Flag) then
begin
if Assigned(FError) then Ferror(Self, FSource, FDestination, SysErrorMessage(GetLastError));
end
else
begin
if Assigned(FProgress) then FProgress(Self, FSource, FDestination, 100);
if Assigned(FTerminated) then FTerminated(Self, FSource, FDestination);
end;
end else if Assigned(FError) then Ferror(Self, FSource, FDestination, 'The source file does not exist');
FTimer.Enabled := False;
Terminate;
except
on E: Exception do SendExcept(Self, 'TMyThreadCopy.Execute', E.Message);
end;
end;
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TMyThreadCopy.OnTimer(Sender: TObject);
begin
try
FCriticalSection.Enter;
try
if Assigned(FProgress) then FProgress(Self, FSource, FDestination, FPosition);
finally
FCriticalSection.Leave;
end;
except
on E: Exception do SendExcept(Self, 'TMyThreadCopy.OnTimer', E.Message);
end;
end;
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TMyThreadCopy.SendExcept(Sender: TObject; ProcedureName, Msg: String);
begin
if Assigned(FExcept) then FExcept(Self, ProcedureName, Msg);
end;
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
end. |
Partager