Как сделать калькулятор в Delphi?
Delphi - объектно-ориентированный язык программирования, разработанный компанией Borland в 1995 году. Он основан на языке программирования Pascal, но имеет более расширенные возможности и добавлены новые функции.
Как Delphi реализует многоплатформенную разработку?
Delphi является интегрированной средой разработки (IDE), которая позволяет разрабатывать программное обеспечение для различных платформ, включая Windows, macOS, Android и iOS. Delphi достигает многоплатформенности с помощью...
Пример 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
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
.