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

{*************************************************************}
{ 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
 if Assigned(FDoneString) then
 FDoneString(Self, FThread.FTStringResult)
 else
 if Assigned(FError) then FError(Self);
 FThread := nil;
end;
procedure Register;
begin
 RegisterComponents('UtilMind', [THTTPGet]);
end;
end.
Source: Взято с http://delphiworld.narod.ru
ID: 03370
Category:Связь