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