type
TForm1 =
class(TForm)
ProgressBar1: TProgressBar;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure WndProc(
var Msg: TMessage);
override;
end;
var
Form1 : TForm1;
implementation
{$R *.dfm}
type
TCopyEx =
packed record
Source:
String[255];
Dest:
String[255];
Handle: THandle;
end;
PCopyEx = ^TCopyEx;
const
CEXM_CANCEL = WM_USER + 1;
CEXM_CONTINUE = WM_USER + 2;
// wParam: lopart, lParam: hipart
CEXM_MAXBYTES = WM_USER + 3;
// wParam: lopart; lParam: hipart
var
CancelCopy : Boolean = False;
function CopyFileProgress(TotalFileSize, TotalBytesTransferred, StreamSize,
StreamBytesTransferred: LARGE_INTEGER; dwStreamNumber, dwCallbackReason,
hSourceFile, hDestinationFile: DWORD; lpData: Pointer): DWORD;
stdcall;
begin
if CancelCopy = True
then
begin
SendMessage(THandle(lpData), CEXM_CANCEL, 0, 0);
result := PROGRESS_CANCEL;
exit;
end;
case dwCallbackReason
of
CALLBACK_CHUNK_FINISHED:
begin
SendMessage(THandle(lpData), CEXM_CONTINUE, TotalBytesTransferred.LowPart, TotalBytesTransferred.HighPart);
result := PROGRESS_CONTINUE;
end;
CALLBACK_STREAM_SWITCH:
begin
SendMessage(THandle(lpData), CEXM_MAXBYTES, TotalFileSize.LowPart, TotalFileSize.HighPart);
result := PROGRESS_CONTINUE;
end;
else
result := PROGRESS_CONTINUE;
end;
end;
procedure TForm1.WndProc(
var Msg: TMessage);
begin
inherited;
case Msg.Msg
of
CEXM_MAXBYTES:
begin
ProgressBar1.Max := Msg.WParam + Msg.LParam;
end;
CEXM_CONTINUE:
begin
Progressbar1.Position := Msg.WParam + Msg.LParam;
Caption := IntToStr(Msg.WParam + Msg.LParam);
end;
CEXM_CANCEL:
begin
Progressbar1.Position := 0;
Caption := '
0';
end;
end;
end;
function CopyExThread(p: PCopyEx): Integer;
var
Source:
String;
Dest:
String;
Handle: THandle;
Cancel : PBool;
begin
Source := p.Source;
Dest := p.Dest;
Handle := p.Handle;
Cancel := PBOOL(False);
CopyFileEx(PChar(Source), PChar(Dest), @CopyFileProgress, Pointer(
Handle), Cancel, 0);
Dispose(p);
result := 0;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Params: PCopyEx;
ThreadID: Cardinal;
begin
cancelCopy := False;
New(Params);
Params.Source := '
H:\Videos ungebrannt\Gwen Stefani - rich girl.mpeg';
Params.Dest := '
H:\test.mpeg';
Params.Handle :=
Handle;
CloseHandle(BeginThread(
nil, 0, @CopyExThread, Params, 0, ThreadID));
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
CancelCopy := True;
end;