Program Source: http://www.swissdelphicles.ch/en/showcode.php? Id = 330
{ 1. }
{
You NEED A TPROGRESSBAR ON YOUR FORM for this TIP.
Für Diesen Tip Wird Eine TprogressBar Benötigt.
}
Procedure TFORM1.CopyFileWithProgressbar1 (Source, Destination: String);
VAR
Fromf, TOF: File of byte;
Buffer: array [0..4096] of char;
NumRead: integer;
FileLength: longint;
Begin
Assignfile (fromf, source);
RESET (FROMF);
Assignfile (TOF, DESTINATION);
Rewrite (TOF);
FileLength: = FileSize (fromf);
With progressbar1 do
Begin
MIN: = 0;
Max: = filelength;
While FileLength> 0 DO
Begin
Blockread (fromf, buffer [0], sizeof (buffer), numread;
FileLength: = FileLength - Numread;
Blockwrite (TOF, BUFFER [0], NumRead;
Position: = POSITION NUMREAD;
END;
Closefile (fromf);
Closefile (TOF);
END;
END;
Procedure TFORM1.BUTTON1CLICK (Sender: TOBJECT);
Begin
CopyFileWithProgressbar1 ('c: /windows/welcome.exe', 'c: /temp/welcome.exe');
END;
{ 2. }
{**************************************
// to show the Estimated Time to Copy A File:
Procedure TFORM1.CopyFileWithProgressbar1 (Source, Destination: String);
VAR
Fromf, TOF: File of byte;
Buffer: array [0..4096] of char;
NumRead: integer;
FileLength: longint;
T1, T2: DWORD;
Maxi: integer;
Begin
Assignfile (fromf, source);
RESET (FROMF);
Assignfile (TOF, DESTINATION);
Rewrite (TOF);
FileLength: = FileSize (fromf);
With progressbar1 do
Begin
MIN: = 0;
Max: = filelength;
T1: = TimegetTime;
Maxi: = Max Div 4096;
While FileLength> 0 DO
Begin
Blockread (fromf, buffer [0], sizeof (buffer), numread;
FileLength: = FileLength - Numread;
Blockwrite (TOF, BUFFER [0], NumRead;
T2: = TimegetTime;
MIN: = min 1; // show the time in label1
Label1.caption: = formatfloat ('0.00', ((T2 - T1) / MIN * MAXI - T2 T1) / 100);
Application.ProcessMESSAGES;
Position: = POSITION NUMREAD;
END;
Closefile (fromf);
Closefile (TOF);
END;
END;
{3.}
{**************************************
// to show the estimated time to copy a file, using a callback function:
Type
TCALLBACK = procedure (position, size: longint); {export;
Procedure FastFileCopy (Const InfileName: String)
Callback: tcallback;
IMPLEMentation
Procedure fastfilecopycallback (position, size: longint);
Begin
Form1.progressbar1.max: = size;
Form1.ProgressBar1.position: = position;
END;
Procedure FastFileCopy (Const InfileName: String)
Callback: tcallback;
Const
Bufsize = 3 * 4 * 4096; {48kbytes gives me the best results}
Type
PBuffer = ^ TBuffer;
TBuffer = array [1..bufsize] of byte;
VAR
Size: DWORD;
Buffer: PBuffer;
Infile, Outfile: File;
Sizedone, Sizefile: longint;
Begin
IF (InfileName <> outfilename) THEN
Begin
BUFFER: = NIL;
Assign (Infile, InfileName);
RESET (Infile, 1);
Try
Sizefile: = filesize (Infile);
Assign (Outfile, OutfileName);
Rewrite (Outfile, 1);
Try
SizeDone: = 0;
NEW (Buffer);
Repeat
Blockread (Infile, Buffer ^, Bufsize, Size);
INC (Sizedone, Size);
Callback (Sizedone, Sizefile);
Blockwrite (Outfile, Buffer ^, Size)
Until size FileSetDate (TfileRec (Outfile) .handle, FilegetDate (TFileRec (Infile)); Finally IF buffer <> nil dam Dispose (buffer); Closefile (Outfile) END; Finally Closefile (Infile); END; end Else Raise EinouTerror.create ('File Cannot Be copied ONTO itself') end; {fastfilecopy} Procedure TFORM1.BUTTON1CLICK (Sender: TOBJECT); Begin FastFileCopy ('c: /daten.txt', 'c: /te/daten2.txt', @fastfilecopycallback); END; {4.} {************************************** Function CopyFileWithProgressbar2 (TotalFileSize, TotalbyTestransferred, StreetSize, StreambyTestransferred: large_integer; DWStreamNumber, DWCallbackreason: DWORD; HSourcefile, HDestinationFile: thandle; LPDATA: POINTER: DWORD; STDCALL; Begin // Just Set Size At the Beginning IF dwcallbackreason = callback_stream_switch dam TProgressBar (LPDATA) .max: = TotalFileSize.quadpart; TPROGRESSBAR (LPDATA) .Position: = TotalbytestransferRed.quadpart; Application.ProcessMESSAGES; Result: = progress_continue; END; Function TFORM1.COPYWITHPROGRESS (SSOURCE, SDEST: STRING): Boolean Begin // set this fcancelled to true, if you want to cancel the copy operation Fcancelled: = FALSE; Result: = CopyfileEx (Pchar (SSOource), Pchar (SDEST), @ CopyFileWithProgressbar2, Progressbar1, @fcancelled, 0); END; END;
