Пример HTTP Get — загружаем файлы и страницы из Интернета

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Встречаются два сис-админа. Один жалуется:

— Ну совсем рехнулся со своей работой. Вчера шел к тебе, набрал на домофоне 192.168… Никто не откликнулся, ну я и ушел… Второй отвечает:

— А ты не пробовал: 255.255.255.255?

{*************************************************************}

{ HTTPGet component for Delphi 32 }

{ Version: 1.94 }

{ E-Mail: info@utilmind.com }

{ WWW: http://www.utilmind.com }

{ Created: October 19, 1999 }

{ Modified: June 6, 2000 }

{ Legal: Copyright (c) 1999-2000, UtilMind Solutions }

{*************************************************************}

{ PROPERTIES: }

{ Agent: String — User Agent }

{ }

{* BinaryData: Boolean — This setting specifies which type }

{* of data will taken from the web. }

{* If you set this property TRUE then }

{* component will determinee the size }

{* of files *before* getting them from }

{* the web. }

{* If this property is FALSE then as we}

{* do not knows the file size the }

{* OnProgress event will doesn’t work. }

{* Also please remember that is you set}

{* this property as TRUE you will not }

{* capable to get from the web ASCII }

{* data and ofter got OnError event. }

{ }

{ FileName: String — Path to local file to store the data }

{ taken from the web }

{ Password, UserName — set this properties if you trying to }

{ get data from password protected }

{ directories. }

{ Referer: String — Additional data about referer document }

{ URL: String — The url to file or document }

{ UseCache: Boolean — Get file from the Internet Explorer’s }

{ cache if requested file is cached. }

{*************************************************************}

{ METHODS: }

{ GetFile — Get the file from the web specified in the URL }

{ property and store it to the file specified in }

{ the FileName property }

{ GetString — Get the data from web and return it as usual }

{ String. You can receive this string hooking }

{ the OnDoneString event. }

{ Abort — Stop the current session }

{*************************************************************}

{ EVENTS: }

{ OnDoneFile — Occurs when the file is downloaded }

{ OnDoneString — Occurs when the string is received }

{ OnError — Occurs when error happend }

{ OnProgress — Occurs at the receiving of the BINARY DATA }

{*************************************************************}

{ Please see demo program for more information. }

{*************************************************************}

{ IMPORTANT NOTE: }

{ This software is provided ‘as-is’, without any express or }

{ implied warranty. In no event will the author be held }

{ liable for any damages arising from the use of this }

{ software. }

{ Permission is granted to anyone to use this software for }

{ any purpose, including commercial applications, and to }

{ alter it and redistribute it freely, subject to the }

{ following restrictions: }

{ 1. The origin of this software must not be misrepresented, }

{ you must not claim that you wrote the original software. }

{ If you use this software in a product, an acknowledgment }

{ in the product documentation would be appreciated but is }

{ not required. }

{ 2. Altered source versions must be plainly marked as such, }

{ and must not be misrepresented as being the original }

{ software. }

{ 3. This notice may not be removed or altered from any }

{ source distribution. }

{*************************************************************}

unit HTTPGet;

interface

uses

Windows, Messages, SysUtils, Classes, WinInet;

type

TOnProgressEvent = procedure(Sender: TObject; TotalSize, Readed: Integer) of object;

TOnDoneFileEvent = procedure(Sender: TObject; FileName: String; FileSize: Integer) of object;

TOnDoneStringEvent = procedure(Sender: TObject; Result: String) of object;

THTTPGetThread = class(TThread)

private

FTAcceptTypes,

FTAgent,

FTURL,

FTFileName,

FTStringResult,

FTUserName,

FTPassword,

FTPostQuery,

FTReferer: String;

FTBinaryData,

FTUseCache: Boolean;

FTResult: Boolean;

FTFileSize: Integer;

FTToFile: Boolean;

BytesToRead, BytesReaded: DWord;

FTProgress: TOnProgressEvent;

procedure UpdateProgress;

protected

procedure Execute; override;

public

constructor Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName, aPassword,

aPostQuery, aReferer: String; aBinaryData, aUseCache:

Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);

end;

THTTPGet = class(TComponent)

private

FAcceptTypes: String;

FAgent: String;

FBinaryData: Boolean;

FURL: String;

FUseCache: Boolean;

FFileName: String;

FUserName: String;

FPassword: String;

FPostQuery: String;

FReferer: String;

FWaitThread: Boolean;

FThread: THTTPGetThread;

FError: TNotifyEvent;

FResult: Boolean;

FProgress: TOnProgressEvent;

FDoneFile: TOnDoneFileEvent;

FDoneString: TOnDoneStringEvent;

procedure ThreadDone(Sender: TObject);

public

constructor Create(aOwner: TComponent); override;

destructor Destroy; override;

procedure GetFile;

procedure GetString;

procedure Abort;

published

property AcceptTypes: String read FAcceptTypes write FAcceptTypes;

property Agent: String read FAgent write FAgent;

property BinaryData: Boolean read FBinaryData write FBinaryData;

property URL: String read FURL write FURL;

property UseCache: Boolean read FUseCache write FUseCache;

property FileName: String read FFileName write FFileName;

property UserName: String read FUserName write FUserName;

property Password: String read FPassword write FPassword;

property PostQuery: String read FPostQuery write FPostQuery;

property Referer: String read FReferer write FReferer;

property WaitThread: Boolean read FWaitThread write FWaitThread;

property OnProgress: TOnProgressEvent read FProgress write FProgress;

property OnDoneFile: TOnDoneFileEvent read FDoneFile write FDoneFile;

property OnDoneString: TOnDoneStringEvent read FDoneString write FDoneString;

property OnError: TNotifyEvent read FError write FError;

end;

procedure Register;

implementation

// THTTPGetThread

constructor THTTPGetThread.Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName,

aPassword, aPostQuery, aReferer: String; aBinaryData, aUseCache:

Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);

begin

FreeOnTerminate := True;

inherited Create(True);

FTAcceptTypes := aAcceptTypes;

FTAgent := aAgent;

FTURL := aURL;

FTFileName := aFileName;

FTUserName := aUserName;

FTPassword := aPassword;

FTPostQuery := aPostQuery;

FTReferer := aReferer;

FTProgress := aProgress;

FTBinaryData := aBinaryData;

FTUseCache := aUseCache;

FTToFile := aToFile;

Resume;

end;

procedure THTTPGetThread.UpdateProgress;

begin

FTProgress(Self, FTFileSize, BytesReaded);

end;

procedure THTTPGetThread.Execute;

var

hSession, hConnect, hRequest: hInternet;

HostName, FileName: String;

f: File;

Buf: Pointer;

dwBufLen, dwIndex: DWord;

Data: Array[0..$400] of Char;

TempStr: String;

RequestMethod: PChar;

InternetFlag: DWord;

AcceptType: LPStr;

procedure ParseURL(URL: String; var HostName, FileName: String);

procedure ReplaceChar(c1, c2: Char; var St: String);

var

p: Integer;

begin

while True do

begin

p := Pos(c1, St);

if p = 0 then Break

else St[p] := c2;

end;

end;

var

i: Integer;

begin

if Pos(‘http://’, LowerCase(URL)) 0 then

System.Delete(URL, 1, 7);

i := Pos(‘/’, URL);

HostName := Copy(URL, 1, i);

FileName := Copy(URL, i, Length(URL) — i 1);

if (Length(HostName) > 0) and (HostName[Length(HostName)] = ‘/’) then

SetLength(HostName, Length(HostName) — 1);

end;

procedure CloseHandles;

begin

InternetCloseHandle(hRequest);

InternetCloseHandle(hConnect);

InternetCloseHandle(hSession);

end;

begin

try

ParseURL(FTURL, HostName, FileName);

if Terminated then

begin

FTResult := False;

Exit;

end;

if FTAgent » then

hSession := InternetOpen(PChar(FTAgent),

INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0)

else

hSession := InternetOpen(nil,

INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

hConnect := InternetConnect(hSession, PChar(HostName),

INTERNET_DEFAULT_HTTP_PORT, PChar(FTUserName), PChar(FTPassword), INTERNET_SERVICE_HTTP, 0, 0);

if FTPostQuery = » then RequestMethod := ‘GET’

else RequestMethod := ‘POST’;

if FTUseCache then InternetFlag := 0

else InternetFlag := INTERNET_FLAG_RELOAD;

AcceptType := PChar(‘Accept: ‘ FTAcceptTypes);

hRequest := HttpOpenRequest(hConnect, RequestMethod, PChar(FileName), ‘HTTP/1.0’,

PChar(FTReferer), @AcceptType, InternetFlag, 0);

if FTPostQuery = » then

HttpSendRequest(hRequest, nil, 0, nil, 0)

else

HttpSendRequest(hRequest, ‘Content-Type: application/x-www-form-urlencoded’, 47,

PChar(FTPostQuery), Length(FTPostQuery));

if Terminated then

begin

CloseHandles;

FTResult := False;

Exit;

end;

dwIndex := 0;

dwBufLen := 1024;

GetMem(Buf, dwBufLen);

FTResult := HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH,

Buf, dwBufLen, dwIndex);

if Terminated then

begin

FreeMem(Buf);

CloseHandles;

FTResult := False;

Exit;

end;

if FTResult or not FTBinaryData then

begin

if FTResult then

FTFileSize := StrToInt(StrPas(Buf));

BytesReaded := 0;

if FTToFile then

begin

AssignFile(f, FTFileName);

Rewrite(f, 1);

end

else FTStringResult := »;

while True do

begin

if Terminated then

begin

if FTToFile then CloseFile(f);

FreeMem(Buf);

CloseHandles;

FTResult := False;

Exit;

end;

if not InternetReadFile(hRequest, @Data, SizeOf(Data), BytesToRead) then Break

else

if BytesToRead = 0 then Break

else

begin

if FTToFile then

BlockWrite(f, Data, BytesToRead)

else

begin

TempStr := Data;

SetLength(TempStr, BytesToRead);

FTStringResult := FTStringResult TempStr;

end;

inc(BytesReaded, BytesToRead);

if Assigned(FTProgress) then

Synchronize(UpdateProgress);

end;

end;

if FTToFile then

FTResult := FTFileSize = Integer(BytesReaded)

else

begin

SetLength(FTStringResult, BytesReaded);

FTResult := BytesReaded 0;

end;

if FTToFile then CloseFile(f);

end;

FreeMem(Buf);

CloseHandles;

except

end;

end;

// HTTPGet

constructor THTTPGet.Create(aOwner: TComponent);

begin

inherited Create(aOwner);

FAcceptTypes := ‘*/*’;

FAgent := ‘UtilMind HTTPGet’;

end;

destructor THTTPGet.Destroy;

begin

Abort;

inherited Destroy;

end;

procedure THTTPGet.GetFile;

var

Msg: TMsg;

begin

if not Assigned(FThread) then

begin

FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName,

FPassword, FPostQuery, FReferer, FBinaryData, FUseCache, FProgress, True);

FThread.OnTerminate := ThreadDone;

if FWaitThread then

while Assigned(FThread) do

while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do

begin

TranslateMessage(Msg);

DispatchMessage(Msg);

end;

end

end;

procedure THTTPGet.GetString;

var

Msg: TMsg;

begin

if not Assigned(FThread) then

begin

FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName,

FPassword, FPostQuery, FReferer, FBinaryData, FUseCache, FProgress, False);

FThread.OnTerminate := ThreadDone;

if FWaitThread then

while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do

begin

TranslateMessage(Msg);

DispatchMessage(Msg);

end;

end

end;

procedure THTTPGet.Abort;

begin

if Assigned(FThread) then

begin

FThread.Terminate;

FThread.FTResult := False;

end;

end;

procedure THTTPGet.ThreadDone(Sender: TObject);

begin

FResult := FThread.FTResult;

if FResult then

if FThread.FTToFile then

if Assigned(FDoneFile) then FDoneFile(Self, FThread.FTFileName, FThread.FTFileSize) else

else

if Assigned(FDoneString) then FDoneString(Self, FThread.FTStringResult) else

else

if Assigned(FError) then FError(Self);

FThread := nil;

end;

procedure Register;

begin

RegisterComponents(‘UtilMind’, [THTTPGet]);

end;

end.

{/codecitation}

Добавить комментарий