Как скачать файл из интернету и показать прогресс. [Wininet]

20:51
unit Unit1;
 
interface
 
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Wininet, StdCtrls, ComCtrls;
 
type
TForm1 = class(TForm)
Button1: TButton;
ProgressBar1: TProgressBar;
StatusBar1: TStatusBar;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
function DownloadURL(AUrl, TargetDir: string):
Boolean;
public
{ Public declarations }
end;
 
var
Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
function fName(AUrl: string): string;
var
i: integer;
begin
result := '';
for i := length(AUrl) downto 0 do
begin
if AUrl[i] = '/' then exit;
result := AUrl[i] + result;
 
end;
end;
 
function TForm1.DownloadURL(AUrl, TargetDir: string):
Boolean;
const
BUFFERSIZE = 4096;
var
F: file;
hSession: HINTERNET;
hService: HINTERNET;
lpBuffer: array[0..BufferSize + 1] of Byte;
BufferLength: DWORD;
dwSizeOfRq, Reserved, dwByteToRead: DWORD;
TargetFileName: string;
fsize: DWORD;
begin
Result := False;
hSession := InternetOpen('MyApp', // Agent
INTERNET_OPEN_TYPE_PRECONFIG, // dwAccessType
nil, // lpszProxyName (optional)
nil, // lpszProxyBypass (optional)
0); // dwFlags
StatusBar1.SimpleText := 'InternetOpen';
if hSession = nil then
begin
ShowMessage('Internet session initialization failed!');
StatusBar1.SimpleText := 'Internet session initialization failed!';
Exit;
end;
hService := InternetOpenUrl(hSession,
PChar(AUrl),
nil,
0,
INTERNET_FLAG_DONT_CACHE or
INTERNET_FLAG_PRAGMA_NOCACHE or
INTERNET_FLAG_RELOAD,
0);
StatusBar1.SimpleText := 'InternetOpenUrl';
if hSession = nil then
begin
ShowMessage('Internet session initialization failed!');
StatusBar1.SimpleText := 'Internet session initialization failed!';
InternetCloseHandle(hService);
Exit;
end;
 
HttpQueryInfo(hService, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER,
@dwByteToRead,
dwSizeOfRq, Reserved);
StatusBar1.SimpleText := 'HttpQueryInfo HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER';
 
TargetFileName := 'c:\Temp\' + fName(AUrl);
AssignFile(F, TargetFileName);
Rewrite(F, 1);
if IOResult <> 0 then
begin
ShowMessage('Cannot create local file');
StatusBar1.SimpleText := 'Cannot create local file';
 
InternetCloseHandle(hService);
Exit;
end;
BufferLength := BUFFERSIZE;
dwByteToRead := 0;
dwSizeOfRq := 4; // BufferLength
Reserved := 0;
if not HttpQueryInfo(hService,
HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER,
@dwByteToRead,
dwSizeOfRq,
Reserved) then dwByteToRead := 0;
ProgressBar1.max := dwByteToRead;
FSize := 0;
 
BufferLength := BUFFERSIZE;
 
while (BufferLength > 0) do
begin
if not InternetReadFile(hService, @lpBuffer, BUFFERSIZE, BufferLength)
then Break;
if (BufferLength > 0) and (BufferLength <= BUFFERSIZE) then
BlockWrite(F, lpBuffer, BufferLength);
application.ProcessMessages;
fsize := fsize + BufferLength;
StatusBar1.SimpleText := inttostr(fsize) + ' in ' + inttostr(dwByteToRead) + ' bytes complete..';
form1.ProgressBar1.Position := fsize;
if BufferLength > 0 then Result := True;
end; {while}
 
CloseFile(F);
Result := True;
StatusBar1.SimpleText := 'Done..';
ProgressBar1.Visible := false;
InternetCloseHandle(hService);
end;
 
 
procedure TForm1.Button1Click(Sender: TObject);
begin
ProgressBar1.Position := 0;
ProgressBar1.Visible := true;
DownloadURL(edit1.Text, 'c:\Temp');
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
Edit1.Text:='http://www.ya.ru/logo.gif';
end;
 
end.