Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

01.01.2007
{*************************************************************}
{            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.

Взято с https://delphiworld.narod.ru