Download file from internet within a thread in Delphi - delphi

How to download a file from internet with progress bar using threads in Delphi 2009/10 without Indy components?

I don't like to use indy either, my reason is it is too large. You could also use wininet. I have written the following for a small project required small app size.
unit wininetUtils;
interface
uses Windows, WinInet
{$IFDEF KOL}
,KOL
{$ELSE}
,Classes
{$ENDIF}
;
type
{$IFDEF KOL}
_STREAM = PStream;
_STRLIST = PStrList;
{$ELSE}
_STREAM = TStream;
_STRLIST = TStrings;
{$ENDIF}
TProgressCallback = function (ATotalSize, ATotalRead, AStartTime: DWORD): Boolean;
function DownloadToFile(const AURL: String; const AFilename: String;
const AAgent: String = '';
const AHeaders: _STRLIST = nil;
const ACallback: TProgressCallback = nil
) : LongInt;
function DownloadToStream(AURL: String; AStream: _STREAM;
const AAgent: String = '';
const AHeaders: _STRLIST = nil;
const ACallback: TProgressCallback = nil
) : LongInt;
implementation
function DownloadToFile(const AURL: String; const AFilename: String;
const AAgent: String = '';
const AHeaders: _STRLIST = nil;
const ACallback: TProgressCallback = nil
) : LongInt;
var
FStream: _STREAM;
begin
{$IFDEF KOL}
// fStream := NewFileStream(AFilename, ofCreateNew or ofOpenWrite);
// fStream := NewWriteFileStream(AFilename);
fStream := NewMemoryStream;
{$ELSE}
fStream := TFileStream.Create(AFilename, fmCreate);
// _STRLIST = TStrings;
{$ENDIF}
try
Result := DownloadToStream(AURL, FStream, AAgent, AHeaders, ACallback);
fStream.SaveToFile(AFilename, 0, fStream.Size);
finally
fStream.Free;
end;
end;
function StrToIntDef(const S: string; Default: Integer): Integer;
var
E: Integer;
begin
Val(S, Result, E);
if E <> 0 then Result := Default;
end;
function DownloadToStream(AURL: String; AStream: _STREAM;
const AAgent: String = '';
const AHeaders: _STRLIST = nil;
const ACallback: TProgressCallback = nil
) : LongInt;
function _HttpQueryInfo(AFile: HINTERNET; AInfo: DWORD): string;
var
infoBuffer: PChar;
dummy: DWORD;
err, bufLen: DWORD;
res: LongBool;
begin
Result := '';
bufLen := 0;
dummy := 0;
infoBuffer := nil;
res := HttpQueryInfo(AFile, AInfo, infoBuffer, bufLen, dummy);
if not res then
begin
// Probably working offline, or no internet connection.
err := GetLastError;
if err = ERROR_HTTP_HEADER_NOT_FOUND then
begin
// No headers
end else if err = ERROR_INSUFFICIENT_BUFFER then
begin
GetMem(infoBuffer, bufLen);
try
HttpQueryInfo(AFile, AInfo, infoBuffer, bufLen, dummy);
Result := infoBuffer;
finally
FreeMem(infoBuffer);
end;
end;
end;
end;
procedure ParseHeaders;
begin
end;
const
BUFFER_SIZE = 16184;
var
buffer: array[1..BUFFER_SIZE] of byte;
Totalbytes, Totalread, bytesRead, StartTime: DWORD;
hInet: HINTERNET;
reply: String;
hFile: HINTERNET;
begin
Totalread := 0;
Result := 0;
hInet := InternetOpen(PChar(AAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil,nil,0);
if hInet = nil then Exit;
try
hFile := InternetOpenURL(hInet, PChar(AURL), nil, 0, 0, 0);
if hFile = nil then Exit;
StartTime := GetTickCount;
try
if AHeaders <> nil then
begin
AHeaders.Text := _HttpQueryInfo(hFile, HTTP_QUERY_RAW_HEADERS_CRLF);
ParseHeaders;
end;
Totalbytes := StrToIntDef(_HttpQueryInfo(hFile,
HTTP_QUERY_CONTENT_LENGTH), 0);
reply := _HttpQueryInfo(hFile, HTTP_QUERY_STATUS_CODE);
if reply = '200' then
// File exists, all ok.
result := 200
else if reply = '401' then
// Not authorised. Assume page exists,
// but we can't check it.
result := 401
else if reply = '404' then
// No such file.
result := 404
else if reply = '500' then
// Internal server error.
result := 500
else
Result := StrToIntDef(reply, 0);
repeat
InternetReadFile(hFile, #buffer, SizeOf(buffer), bytesRead);
if bytesRead > 0 then
begin
AStream.Write(buffer, bytesRead);
Inc(Totalread, bytesRead);
if Assigned(ACallback) then
begin
if not ACallback(TotalBytes, Totalread, StartTime) then Break;
end;
Sleep(10);
end;
// BlockWrite(localFile, buffer, bytesRead);
until bytesRead = 0;
finally
InternetCloseHandle(hFile);
end;
finally
InternetCloseHandle(hInet);
end;
end;
end.

This uses the clever internet suite to handle the download, I haven't so much as checked it in the IDE so I wouldn't expect it to compile and no doubt it's full of errors but it should be enough to get you started.
I don't know why you don't want to use Indy but I would strongly advise getting some components to help with the Http download... there really is no need to reinvent the wheel.
interface
type
TMyDownloadThread= Class(TThread)
private
FUrl: String;
FFileName: String;
FProgressHandle: HWND;
procedure GetFile (Url: String; Stream: TStream; ReceiveProgress: TclSocketProgressEvent);
procedure OnReceiveProgress(Sender: TObject; ABytesProceed, ATotalBytes: Integer);
procedure SetPercent(Percent: Double);
protected
Procedure Execute; Override;
public
Constructor Create(Url, FileName: String; PrograssHandle: HWND);
End;
implementation
constructor TMyDownloadThread.Create(Url, FileName: String; PrograssHandle: HWND);
begin
Inherited Create(True);
FUrl:= Url;
FFileName:= FileName;
FProgressHandle:= PrograssHandle;
Resume;
end;
procedure TMyDownloadThread.GetFile(Url: String; Stream: TStream; ReceiveProgress: TclSocketProgressEvent);
var
Http: TclHttp;
begin
Http := TclHTTP.Create(nil);
try
try
Http.OnReceiveProgress := ReceiveProgress;
Http.Get(Url, Stream);
except
end;
finally
Http.Free;
end;
end;
procedure TMyDownloadThread.OnReceiveProgress(Sender: TObject; ABytesProceed, ATotalBytes: Integer);
begin
SetPercent((ABytesProceed / ATotalBytes) * 100);
end;
procedure TMyDownloadThread.SetPercent(Percent: Double);
begin
PostMessage(FProgressHandle, AM_DownloadPercent, LowBytes(Percent), HighBytes(Percent));
end;
procedure TMyDownloadThread.Execute;
var
FileStream: TFileStream;
begin
FileStream := TFileStream.Create(FFileName, fmCreate);
try
GetFile(FUrl, FileStream, OnReceiveProgress);
finally
FileStream.Free;
end;
end;

Related

Redirect stdout stream from console application (CreateProcess)

Recently I finally managed to redirect console application output to TMemo text field of another application using an example from Microsoft: https://learn.microsoft.com/en-us/windows/win32/procthread/creating-a-child-process-with-redirected-input-and-output
All the classical examples run a console executable, wait till it ends and then read its STDOUT. I would like to launch a long-running executable that is normally not intended to end, and get its STDOUT stream as soon as new characters become available.
I managed to modify this example so that a read-write part is a loop and runs in a thread (TProcessExecuterThread.Execute). Now I am in doubt whether I should use the thread at all.
Additionally, the host receives not the whole strings till CR-LF even if I get from a pipe one character after other (TProcessExecuterThread.ReadFromPipe).
Finally I am concerned what about ending the host. The guest should then receive a signal to terminate and after some timeout - should be killed. Where (not "how") is it better to organize this?
Here is the console guest application for the test:
{$APPTYPE CONSOLE}
program GuestApp;
uses System.SysUtils;
var i: Integer;
begin
Writeln('Ongoing console output:');
for i := 0 to 65535 do begin //while True do begin
if i mod 2 = 0 then Write('*');
Writeln(Format('Output line %d', [i]));
Sleep(500);
end;
end.
Here is the host application (sorry, it is not short):
unit Executer;
interface
uses Winapi.Windows, System.Classes, System.Generics.Collections;
type
TProcessExecuterThread = class(TThread)
private
FStdInQueue: TQueue<string>;
FhChildStdOutRd: THandle;
FhChildStdInWr: THandle;
FOnStdOutLog: TGetStrProc;
procedure ReadFromPipe();
procedure WriteToPipe();
procedure StdOutLog(msg: string);
protected
procedure Execute(); override;
property hChildStdOutRd: THandle read FhChildStdOutRd write FhChildStdOutRd;
property hChildStdInWr: THandle read FhChildStdInWr write FhChildStdInWr;
property OnstdOutLog: TGetStrProc read FOnStdOutLog write FOnStdOutLog;
end;
TProcessExecuter = class
private const
BUFSIZE = 4096;
private
FhChildStdInRd: THandle;
FhChildStdInWr: THandle;
FhChildStdOutRd: THandle;
FhChildStdOutWr: THandle;
FOnLog: TGetStrProc;
FOnStdOutLog: TGetStrProc;
FExThread: TProcessExecuterThread;
procedure CreateChildProcess(ACmdLine: string);
procedure ErrorExit(AFuncName: string);
procedure Log(msg: string);
procedure StdOutLog(const msg: string);
function KillProcess(dwProcID, Wait: DWORD): Integer;
public
constructor Create();
function RunRedirectedProcess(ACmdLine: string): Integer;
property OnLog: TGetStrProc read FOnLog write FOnLog;
property OnstdOutLog: TGetStrProc read FOnStdOutLog write FOnStdOutLog;
end;
implementation
uses System.SysUtils;
procedure TProcessExecuter.Log(msg: string);
begin
if Assigned(FOnLog) then FOnLog(msg);
end;
procedure TProcessExecuter.StdOutLog(const msg: string);
begin
if Assigned(FOnStdOutLog) then FOnStdOutLog(msg);
end;
// Format a readable error message, display a message box,
// and exit from the application.
procedure TProcessExecuter.ErrorExit(AFuncName: string);
var msg: string;
dw: DWORD;
begin
dw := GetLastError();
msg := Format('%s failed with error %d: %s', [AFuncName, dw, SysErrorMessage(dw)]);
Log(msg);
// ExitProcess(1);
end;
constructor TProcessExecuter.Create();
begin
FhChildStdInRd := 0;
FhChildStdInWr := 0;
FhChildStdOutRd := 0;
FhChildStdOutWr := 0;
FExThread := TProcessExecuterThread.Create();
FExThread.OnstdOutLog := StdOutLog;
end;
// Create a child process that uses the previously created pipes for STDIN and STDOUT.
procedure TProcessExecuter.CreateChildProcess(ACmdLine: string);
var
piProcInfo: TProcessInformation;
siStartInfo: TStartupInfo;
bSuccess: Boolean;
begin
try
bSuccess := False;
FillChar(piProcInfo, SizeOf(TProcessInformation), 0);
FillChar(siStartInfo, SizeOf(TStartupInfo), 0);
siStartInfo.cb := SizeOf(TStartupInfo);
siStartInfo.hStdError := FhChildStdOutWr;
siStartInfo.hStdOutput := FhChildStdOutWr;
siStartInfo.hStdInput := FhChildStdInRd;
siStartInfo.dwFlags := siStartInfo.dwFlags or STARTF_USESTDHANDLES;
bSuccess := CreateProcess(nil, PWideChar(ACmdLine), nil, nil, True, 0, nil, nil, siStartInfo, piProcInfo);
if not bSuccess then begin
ErrorExit('CreateProcess');
Exit;
end
else begin
CloseHandle(piProcInfo.hProcess);
CloseHandle(piProcInfo.hThread);
CloseHandle(FhChildStdOutWr);
CloseHandle(FhChildStdInRd);
end;
FExThread.hChildStdOutRd := FhChildStdOutRd;
FExThread.hChildStdInWr := FhChildStdInWr;
except
on ex: Exception do Log(ex.Message);
end;
end;
function TProcessExecuter.RunRedirectedProcess(ACmdLine: string): Integer;
var saAttr: SECURITY_ATTRIBUTES;
i: Integer;
begin
try
Log('->Start of parent execution.');
saAttr.nLength := SizeOf(SECURITY_ATTRIBUTES);
saAttr.bInheritHandle := True;
saAttr.lpSecurityDescriptor := 0;
if not CreatePipe(FhChildStdOutRd, FhChildStdOutWr, #saAttr, 0) then begin
ErrorExit('StdoutRd CreatePipe');
Exit;
end;
if not SetHandleInformation(FhChildStdOutRd, HANDLE_FLAG_INHERIT, 0) then begin
ErrorExit('Stdout SetHandleInformation');
Exit;
end;
if not CreatePipe(FhChildStdInRd, FhChildStdInWr, #saAttr, 0) then begin
ErrorExit('Stdin CreatePipe');
Exit;
end;
if not SetHandleInformation(FhChildStdInWr, HANDLE_FLAG_INHERIT, 0) then begin
ErrorExit('Stdin SetHandleInformation');
Exit;
end;
CreateChildProcess(ACmdLine);
//Read/write loop was here
Log('->End of parent execution.');
if not CloseHandle(FhChildStdInWr) then begin
ErrorExit('StdInWr CloseHandle');
Exit;
end;
Result := 0;
except
on ex: Exception do Log(ex.Message);
end;
end;
procedure TProcessExecuterThread.WriteToPipe();
var dwRead, dwWritten: DWORD;
chBuf: Pointer;
bSuccess: Boolean;
line: string;
bs: Integer;
begin
bSuccess := False;
while FStdInQueue.Count > 0 do begin
line := FStdInQueue.Dequeue();
bs := (Length(line) + 1) * SizeOf(WideChar);
GetMem(chBuf, bs);
try
StrPCopy(PWideChar(chBuf), line);
if not WriteFile(FhChildStdInWr, chBuf^, dwRead, dwWritten, nil) then break;
finally
FreeMem(chBuf, bs);
end;
end;
end;
procedure TProcessExecuterThread.ReadFromPipe();
const BUFSIZE = 1; //4096
var dwRead: DWORD;
//chBuf: array [0 .. BUFSIZE] of CHAR;
chBuf: array [0 .. BUFSIZE] of AnsiChar; // Currently only ANSI is possible
ch: AnsiChar;
bSuccess: Boolean;
begin
bSuccess := False;
while True do begin
//bSuccess := ReadFile(FhChildStdOutRd, chBuf, BUFSIZE, dwRead, nil);
bSuccess := ReadFile(FhChildStdOutRd, ch, 1, dwRead, nil);
if (not bSuccess) or (dwRead = 0) then
break;
//StdOutLog(chBuf);
StdOutLog(ch);
end;
end;
procedure TProcessExecuterThread.StdOutLog(msg: string);
begin
if Assigned(FOnStdOutLog) then
Synchronize(
procedure()
begin
FOnStdOutLog(msg);
end
);
end;
procedure TProcessExecuterThread.Execute;
begin
inherited;
FStdInQueue := TQueue<string>.Create();
try
while not Terminated do begin
WriteToPipe();
ReadFromPipe();
end;
finally
FreeAndNil(FStdInQueue);
end;
end;
end.

Create process by system with delphi

How to create a process by the SYSTEM NT Authority account in Delphi ?
is there an API for it such as CreateProcessAsUser function.
You need to create service that installed & starts at run time by
itself.
On Service execute procedure Call CreateProcessAsUserW with the token of winlogon.exe process.
Notes
if you want the new proccess runs in the same caller session call
WTSQueryUserToken with WtsGetActiveConsoleSessionID to get the
current active user token then call CreateEnvironmentBlock with that
token, and assinge the received pointer on CreateProcessAsUserW.
Set a random Name & DisplayName (such created time) for that
service. if you want to run a multiple SYSTEM process with the same
serevice.
Here what i use
uSysAccount.pas
unit uSysAccount;
interface
uses
WinSvc,
SvcMgr,
Winapi.Windows,
System.SysUtils,
TlHelp32,
System.Classes;
type
TsSysAccount = class(TService)
procedure ServiceExecute(Sender: TService);
private
lpApplicationName,
lpCommandLine,
lpCurrentDirectory: PWideChar;
public
function GetServiceController: TServiceController; override;
end;
procedure CreateProcessAsSystem(const lpApplicationName: PWideChar;
const lpCommandLine:PWideChar = nil;
const lpCurrentDirectory: PWideChar = nil);
var
sSysAccount: TsSysAccount;
implementation
{$R *.dfm}
function WTSQueryUserToken(SessionId: ULONG; var phToken: THandle): BOOL; stdcall; external 'Wtsapi32.dll';
type
TServiceApplicationEx = class(TServiceApplication)
end;
TServiceApplicationHelper = class helper for TServiceApplication
public
procedure ServicesRegister(Install, Silent: Boolean);
end;
function IsUserAnAdmin: BOOL; stdcall; external 'shell32.dll' name 'IsUserAnAdmin';
function CreateEnvironmentBlock(var lpEnvironment: Pointer; hToken: THandle;
bInherit: BOOL): BOOL;
stdcall; external 'Userenv.dll';
function DestroyEnvironmentBlock(pEnvironment: Pointer): BOOL; stdcall; external 'Userenv.dll';
function _GetIntegrityLevel() : DWORD;
type
PTokenMandatoryLabel = ^TTokenMandatoryLabel;
TTokenMandatoryLabel = packed record
Label_ : TSidAndAttributes;
end;
var
hToken : THandle;
cbSize: DWORD;
pTIL : PTokenMandatoryLabel;
dwTokenUserLength: DWORD;
begin
Result := 0;
dwTokenUserLength := MAXCHAR;
if OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, hToken) then begin
pTIL := Pointer(LocalAlloc(0, dwTokenUserLength));
if pTIL = nil then Exit;
cbSize := SizeOf(TTokenMandatoryLabel);
if GetTokenInformation(hToken, TokenIntegrityLevel,
pTIL, dwTokenUserLength, cbSize) then
if IsValidSid( (pTIL.Label_).Sid ) then
Result := GetSidSubAuthority((pTIL.Label_).Sid, GetSidSubAuthorityCount((pTIL.Label_).Sid )^ - 1)^;
if hToken <> INVALID_HANDLE_VALUE then
CloseHandle(hToken);
LocalFree(Cardinal(pTIL));
end;
end;
function IsUserAnSystem(): Boolean;
const
SECURITY_MANDATORY_SYSTEM_RID = $00004000;
begin
Result := (_GetIntegrityLevel = SECURITY_MANDATORY_SYSTEM_RID);
end;
function StartTheService(Service:TService): Boolean;
var
SCM: SC_HANDLE;
ServiceHandle: SC_HANDLE;
begin
Result:= False;
SCM:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if (SCM <> 0) then
begin
try
ServiceHandle:= OpenService(SCM, PChar(Service.Name), SERVICE_ALL_ACCESS);
if (ServiceHandle <> 0) then
begin
Result := StartService(ServiceHandle, 0, pChar(nil^));
CloseServiceHandle(ServiceHandle);
end;
finally
CloseServiceHandle(SCM);
end;
end;
end;
procedure SetServiceName(Service: TService);
begin
if Assigned(Service) then begin
Service.DisplayName := 'Run as system service created ' + DateTimeToStr(Now);
Service.Name := 'RunAsSystem' + FormatDateTime('ddmmyyyyhhnnss', Now);
end;
end;
procedure CreateProcessAsSystem(const lpApplicationName: PWideChar;
const lpCommandLine:PWideChar = nil;
const lpCurrentDirectory: PWideChar = nil);
begin
if not ( IsUserAnAdmin ) then begin
SetLastError(ERROR_ACCESS_DENIED);
Exit();
end;
if not ( FileExists(lpApplicationName) ) then begin
SetLastError(ERROR_FILE_NOT_FOUND);
Exit();
end;
if ( IsUserAnSystem ) then
begin
SvcMgr.Application.Initialize;
SvcMgr.Application.CreateForm(TsSysAccount, sSysAccount);
sSysAccount.lpApplicationName := lpApplicationName;
sSysAccount.lpCommandLine := lpCommandLine;
sSysAccount.lpCurrentDirectory := lpCurrentDirectory;
SetServiceName(sSysAccount);
SvcMgr.Application.Run;
end
else begin
SvcMgr.Application.Free;
SvcMgr.Application := TServiceApplicationEx.Create(nil);
SvcMgr.Application.Initialize;
SvcMgr.Application.CreateForm(TsSysAccount, sSysAccount);
SetServiceName(sSysAccount);
SvcMgr.Application.ServicesRegister(True, True);
try
StartTheService(sSysAccount);
finally
SvcMgr.Application.ServicesRegister(False, True);
end;
end;
end;
procedure TServiceApplicationHelper.ServicesRegister(Install, Silent: Boolean);
begin
RegisterServices(Install, Silent);
end;
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
sSysAccount.Controller(CtrlCode);
end;
function TsSysAccount.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
Function ProcessIDFromAppname32( szExeFileName: String ): DWORD;
var
Snapshot: THandle;
ProcessEntry: TProcessEntry32;
Begin
Result := 0;
szExeFileName := UpperCase( szExeFileName );
Snapshot := CreateToolhelp32Snapshot(
TH32CS_SNAPPROCESS,
0 );
If Snapshot <> 0 Then
try
ProcessEntry.dwSize := Sizeof( ProcessEntry );
If Process32First( Snapshot, ProcessEntry ) Then
Repeat
If Pos( szExeFileName,
UpperCase(ExtractFilename(
StrPas(ProcessEntry.szExeFile)))
) > 0
then Begin
Result:= ProcessEntry.th32ProcessID;
Break;
end;
until not Process32Next( Snapshot, ProcessEntry );
finally
CloseHandle( Snapshot );
end;
End;
function TerminateProcessByID(ProcessID: Cardinal): Boolean;
var
hProcess : THandle;
begin
Result := False;
hProcess := OpenProcess(PROCESS_TERMINATE,False,ProcessID);
if hProcess > 0 then
try
Result := Win32Check(TerminateProcess(hProcess,0));
finally
CloseHandle(hProcess);
end;
end;
procedure TsSysAccount.ServiceExecute(Sender: TService);
var
hToken, hUserToken: THandle;
StartupInfo : TStartupInfoW;
ProcessInfo : TProcessInformation;
P : Pointer;
begin
if NOT WTSQueryUserToken(WtsGetActiveConsoleSessionID, hUserToken) then exit;
if not OpenProcessToken(
OpenProcess(PROCESS_ALL_ACCESS, False,
ProcessIDFromAppname32('winlogon.exe'))
,
MAXIMUM_ALLOWED,
hToken) then exit;
if CreateEnvironmentBlock(P, hUserToken, True) then
begin
ZeroMemory(#StartupInfo, sizeof(StartupInfo));
StartupInfo.lpDesktop := ('winsta0\default');
StartupInfo.wShowWindow := SW_SHOWNORMAL;
if CreateProcessAsUserW(
hToken,
lpApplicationName,
lpCommandLine,
nil,
nil,
False,
CREATE_UNICODE_ENVIRONMENT,
P,
lpCurrentDirectory,
StartupInfo,
ProcessInfo) then
begin
end;
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
DestroyEnvironmentBlock(P);
end;
CloseHandle(hToken);
CloseHandle(hUserToken);
TerminateProcessByID(GetCurrentProcessId);
end;
end.
uSysAccount.dfm
object sSysAccount: TsSysAccount
OldCreateOrder = False
DisplayName = 'sSysAccount'
OnExecute = ServiceExecute
Height = 150
Width = 215
end
Usage as follow ( must run as an administrator )
program Project7;
uses
uSysAccount;
{$R *.res}
begin
CreateProcessAsSystem('c:\windows\system32\cmd.exe');
end.

Delphi 7 - Check if server is online

I have a program created in Delphi 7 that uses ftp downloading.
How can i insert into that program to check for a server status?
For example if server is online to produce a green image, if server is offline o produce a red image. Here is the code.
unit Download;
interface
uses
Classes, Wininet, Windows, SysUtils, Dialogs, Forms;
type
GFilesThread = class(TThread)
private
LTemp : Longword;
STemp : string;
FilesToGet : TStringList;
FilesSize : Longword;
CBackup : integer;
CRevision : integer;
CForceCheck : boolean;
CSwitch : integer;
UUrl : string;
USelfParam : string;
Dir: string;
FSource: TStream;
protected
procedure Execute; override;
procedure UpdateFileProgress;
procedure SetFileProgressMax;
procedure UpdateStatusLabel;
procedure UpdateFileDecompStat;
procedure UpdateFilesProgress;
procedure CheckFiles(FList : TStringList);
procedure BZProgress(Sender: TObject);
procedure LockFMain;
procedure UNLockFMain;
procedure GetFiles;
procedure SelfUpdate(SelfVal : string);
procedure UpdateRevision;
procedure ModHosts(Lines : TStringList);
procedure DoUncompressStream(ASource, ADest: TStream);
procedure DoUncompress(const ASource, ADest: TFileName);
function HTTPGetFile(const fileURL, FileName: string; sh_progress: boolean): boolean;
public
property CreateBackup : integer write CBackup;
property UpdatesUrl : string write UUrl;
property LocalRevision : integer write CRevision;
property ForceCheck : boolean write CForceCheck;
end;
implementation
uses Launcher, CheckFiles, BZip2, md5, FileList;
// -------- by 667
procedure GFilesThread.UpdateStatusLabel;
begin
FMain.Label3.Caption:=STemp;
end;
procedure GFilesThread.SetFileProgressMax;
begin
if(CSwitch=0) then
FMain.Gauge1.MaxValue:=LTemp;
if(CSwitch=1) then
FMain.Gauge2.MaxValue:=LTemp;
end;
procedure GFilesThread.UpdateFileProgress;
begin
FMain.Gauge1.Progress:=LTemp;
end;
procedure GFilesThread.UpdateFilesProgress;
begin
FMain.Gauge2.Progress:=LTemp;
end;
procedure GFilesThread.UpdateRevision;
begin
FMain.UpdateRevision(IntToStr(CRevision));
end;
procedure GFilesThread.UpdateFileDecompStat;
begin
FMain.Gauge1.Progress:=LTemp;
end;
procedure GFilesThread.BZProgress(Sender: TObject);
begin
LTemp:=FSource.Position;
Synchronize(UpdateFileDecompStat);
end;
procedure GFilesThread.LockFMain;
begin
Fmain.ImgBtn1.Visible:=False;
Fmain.ImgBtn2.Visible:=False;
Fmain.ImgBtn5.Enabled:=False;
end;
procedure GFilesThread.UNLockFMain;
begin
Fmain.ImgBtn1.Visible:=True;
Fmain.ImgBtn2.Visible:=True;
Fmain.ImgBtn5.Enabled:=True;
end;
// --------- by 667
function GFilesThread.HTTPGetFile(const fileURL, FileName: string; sh_progress: boolean): boolean;
const
BufferSize = 1024;
var
hSession, hURL: HInternet;
Buffer: array[1..BufferSize] of Byte;
BufferLen: Longword;
f: file;
sAppName: string;
begin
Result := False;
sAppName := 'L2ClientUpdater';
LTemp:=0;
hSession := InternetOpen(PChar(sAppName),
INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
try
hURL := InternetOpenURL(hSession, PChar(fileURL), nil, 0, 0, 0);
if (hURL <> nil) then begin
try
DeleteUrlCacheEntry(PChar(fileURL));
AssignFile(f, FileName);
Rewrite(f,1);
repeat
InternetReadFile(hURL, #Buffer, SizeOf(Buffer), BufferLen);
BlockWrite(f, Buffer, BufferLen);
if (sh_progress) then
begin
LTemp:=LTemp+BufferLen;
Synchronize(UpdateFileProgress);
end;
until
BufferLen = 0;
CloseFile(f);
Result := True;
finally
InternetCloseHandle(hURL);
end;
end;
finally
InternetCloseHandle(hSession);
end;
LTemp:=0;
Synchronize(UpdateFileProgress);
end;
procedure GFilesThread.DoUncompress(const ASource, ADest: TFileName);
var
Source, Dest: TStream;
begin
Source := TFileStream.Create(ASource, fmOpenRead + fmShareDenyWrite);
try
Dest := TFileStream.Create(ADest, fmCreate);
try
DoUncompressStream(Source, Dest);
finally
Dest.Free;
end;
finally
Source.Free;
DeleteFile(ASource);
end;
end;
procedure GFilesThread.DoUncompressStream(ASource, ADest: TStream);
const
BufferSize = 65536;
var
Count: Integer;
Decomp: TBZDecompressionStream;
Buffer: array[0..BufferSize - 1] of Byte;
begin
FSource := ASource;
LTemp:=FSource.Size;
CSwitch:=0;
Synchronize(SetFileProgressMax);
Decomp := TBZDecompressionStream.Create(ASource);
try
Decomp.OnProgress := BZProgress;
while True do
begin
Count := Decomp.Read(Buffer, BufferSize);
if Count <> 0 then ADest.WriteBuffer(Buffer, Count) else Break;
end;
finally
Decomp.Free;
FSource := nil;
LTemp:=0;
Synchronize(UpdateFileDecompStat);
end;
end;
procedure GFilesThread.CheckFiles(FList : TStringList);
var
i: integer;
FParam: TStringList;
FNameLocal: string;
begin
if(FList.Count>0) and (FList[0]<>'FAIL') and (not terminated) then
begin
STemp:='Checking files';
Synchronize(UpdateStatusLabel);
CSwitch:=1;
LTemp:=FList.Count-1;
Synchronize(SetFileProgressMax);
FParam:=TStringList.Create;
for i:=0 to FList.Count-1 do
begin
LTemp:=i;
Synchronize(UpdateFilesProgress);
FParam:=Tokenize(FList[i],'|');
FNameLocal:=Dir+FParam[2];
STemp:='Checking '+FParam[2];
Synchronize(UpdateStatusLabel);
if (not FileExists(FNameLocal)) then
begin
FilesToGet.Add(FList[i]);
FilesSize:=FilesSize+StrToInt(FParam[0]);
end
else
begin
if (MD5Print(MD5File(FNameLocal))<>FParam[1]) then
begin
FilesToGet.Add(FList[i]);
FilesSize:=FilesSize+StrToInt(FParam[0]);
end;
end;
end;
FParam.Free;
LTemp:=0;
Synchronize(UpdateFilesProgress);
STemp:='';
Synchronize(UpdateStatusLabel);
end;
end;
procedure GFilesThread.SelfUpdate(SelfVal : string);
var
FParam: TStringList;
FNameLocal: string;
F:boolean;
begin
if(SelfVal<>'') then
begin
FParam:=TStringList.Create;
FParam:=Tokenize(SelfVal,'|');
FNameLocal:=Dir+FParam[2];
if (MD5Print(MD5File(FNameLocal))<>FParam[1]) then
begin
FilesSize:=FilesSize+StrToInt(FParam[0]);
F:=HTTPGetFile(UUrl+FParam[2]+'.bz2',FNameLocal+'.bz2',True);
if(F) then begin
try
DoUncompress(FNameLocal+'.bz2',Dir+FParam[2]+'.New');
GenKillerBat(FParam[2]);
RunApp(Dir+'Update.bat');
except
STemp:='Update Failed';
DeleteFile(FNameLocal);
end;
end;
end;
FParam.Free;
end;
end;
procedure GFilesThread.ModHosts(Lines : TStringList);
var
Hosts : textfile;
H, HostsStrings, HostLineParam : TStringList;
HostsPath, temp : string;
i, z, funnyFlag : integer;
WindirP : PChar;
Res : cardinal;
begin
WinDirP := StrAlloc(MAX_PATH);
Res := GetWindowsDirectory(WinDirP, MAX_PATH);
if Res > 0 then
begin
if(FileExists(StrPas(WinDirP)+'\system32\drivers\etc\hosts.msn')) then
HostsPath := StrPas(WinDirP)+'\system32\drivers\etc\hosts.msn'
else
HostsPath := StrPas(WinDirP)+'\system32\drivers\etc\hosts';
AssignFile(Hosts,HostsPath);
Reset(Hosts);
HostsStrings:= TStringList.Create;
H:= TStringList.Create;
H.Add('#-------- Added by L2Updater --------');
while (not Eof(Hosts)) do
begin
ReadLn(Hosts, temp);
HostsStrings.Add(Trim(temp));
end ;
Reset(Hosts);
for i:=0 to Lines.Count-1 do
begin
funnyFlag:=0;
HostLineParam:=Tokenize(Lines[i],'|');
for z:=0 to HostsStrings.Count-1 do
begin
if (StrSearch(1,HostsStrings[z],HostLineParam[0])>0) and (HostsStrings[z][1]<>'#') then
begin
if (StrSearch(1,HostsStrings[z],HostLineParam[1]+#9)= 0) and (StrSearch(1,HostsStrings[z],HostLineParam[1]+' ')= 0 ) then
begin
HostsStrings[z]:= '#'+HostsStrings[z];
funnyFlag:=1;
end
else funnyFlag:=2;
end;
end;
if (funnyFlag=1) or (funnyFlag=0) then
H.Add(HostLineParam[1]+#9+HostLineParam[0]);
end;
H.Add('#-----------------');
if H.Count>2 then
begin
Rewrite(Hosts);
STemp:='Applying changes to Hosts';
Synchronize(UpdateStatusLabel);
for i:=0 to HostsStrings.Count-1 do
begin
WriteLn(Hosts,HostsStrings[i]);
end;
for i:=0 to H.Count-1 do
begin
WriteLn(Hosts,H[i]);
end;
STemp:='Hosts file chamged';
Synchronize(UpdateStatusLabel);
end;
H.Free; HostsStrings.Free; HostLineParam.Free;
CloseFile(Hosts);
end;
end;
procedure GFilesThread.GetFiles;
var
FParam : TStringList;
i : integer;
F, error : boolean;
LocalFile, BakFile: string;
begin
error := False;
if (FilesToGet.Count>0) then
begin
FParam:=TStringList.Create;
LTemp:=FilesToGet.Count-1;
CSwitch:=1;
Synchronize(SetFileProgressMax);
i:=0;
while (i < FilesToGet.Count) and (not terminated) do
begin
FParam:=Tokenize(FilesToGet[i],'|');
LocalFile:= Dir+FParam[2];
STemp:='Downloading '+ FParam[2];
Synchronize(UpdateStatusLabel);
CSwitch:=0;
LTemp:= StrToInt(FParam[0]);
Synchronize(SetFileProgressMax);
if (not DirectoryExists(ExtractFilePath(LocalFile))) then
ForceDirectories(ExtractFilePath(LocalFile));
F:=HTTPGetFile(UUrl+ReplaceStr(FParam[2],'\','/')+'.bz2',LocalFile+'.bz2',True);
if (F) then
begin
try
if (CBackup=1) then
begin
BakFile:=Dir+'backup\'+FParam[2];
if (not DirectoryExists(ExtractFilePath(BakFile))) then
ForceDirectories(ExtractFilePath(BakFile));
CopyFile(PChar(LocalFile),PChar(BakFile),false);
end;
STemp:='Extracting '+ FParam[2];
Synchronize(UpdateStatusLabel);
DoUncompress(LocalFile+'.bz2',Dir+FParam[2]);
except
STemp:='Update Failed';
error := True;
end;
end
else
begin
STemp:='Update Failed';
error := True;
Break;
end;
inc(i);
LTemp:=i;
CSwitch:=1;
Synchronize(UpdateFilesProgress);
end;
LTemp:=0;
Synchronize(UpdateFilesProgress);
FParam.Free;
if (not error) then
STemp:='All files have been updated.';
end
else STemp:='';
end;
procedure GFilesThread.Execute;
var
List: TListFile;
CFiles, NFiles, HostsLines : TStringList;
TRev, IsModHosts : integer;
F : boolean;
begin
Dir:=GetCurrentDir+'\';
FilesSize:=0;
Synchronize(LockFMain);
STemp:='Downloading updates list';
Synchronize(UpdateStatusLabel);
if(UUrl[length(UUrl)]<>'/') then UUrl:=UUrl+'/';
F:=HTTPGetFile(UUrl+'files.lst.bz2',Dir+'files.lst.bz2', True);
if (F) then
begin
STemp:='';
Synchronize(UpdateStatusLabel);
try
DoUncompress(Dir+'files.lst.bz2',Dir+'files.lst');
except
STemp:='Update Failed';
Synchronize(UpdateStatusLabel);
DeleteFile(Dir+'files.lst');
end;
if(FileExists(Dir+'files.lst')) then
begin
FilesToGet := TStringList.Create;
List := TListFile.Create(Dir+'files.lst');
CFiles:=TStringList.Create;
TRev:=StrToInt(List.GetKeyValue('settings','Rev'));
IsModHosts:=StrToInt(List.GetKeyValue('settings','ModHosts'));
if (IsModHosts = 1) then
begin
HostsLines:= TStringList.Create;
HostsLines:= List.GetFSection('hosts');
try
ModHosts(HostsLines);
finally
HostsLines.Free;
end;
end;
USelfParam:= List.GetFSection('self')[0];
if(USelfParam<>'FAIL') then SelfUpdate(USelfParam);
CFiles:=List.GetFSection('files_critical');
CheckFiles(CFiles);
CFiles.Free;
if (CForceCheck) or (TRev>CRevision) then
begin
if (CBackup=1) then
begin
DelDir(Dir+'backup');
MkDir(Dir+'backup');
end;
NFiles:=TStringList.Create;
NFiles:=List.GetFSection('files_normal');
CheckFiles(NFiles);
NFiles.Free;
end;
GetFiles;
List.Destroy;
FilesToGet.Free;
DeleteFile(Dir+'files.lst');
if TRev>CRevision then
begin
CRevision:=TRev;
Synchronize(UpdateRevision);
end;
end;
end
else
begin
STemp:='Update Failed';
DeleteFile(Dir+'files.lst');
end;
Synchronize(UpdateStatusLabel);
Synchronize(UNLockFMain);
end;
end.
function CanConnect(const aUserName, aPassword, aHost: String; out aErrm: string): boolean;
var
LocalIDFTP: TIdFTP;
begin
aErrm := '';
LocalIDFTP := TIdFTP.Create(nil);
try
LocalIDFTP.UserName := aUserName;
LocalIDFTP.Password := aPassword;
LocalIDFTP.Host := aHost;
LocalIDFTP.Passive := True;
try
LocalIDFTP.Connect;
LocalIDFTP.Quit;
result := true;
except
on E: Exception do
begin
aErrm := 'Unable to connect to FTP site: ' + E.Message;
Result := FALSE;
end;
end;
finally
if Assigned(LocalIDFTP) then
LocalIDFTP.Free
else
Result := FALSE;
end;
end; {CanConnect}

Why did it fail ,idispatch interface which get by AccessibleObjectFromEvent.call the idispatch's member

I get a ms-word's handle,then use AccessibleObjectFromEvent to get is's IDispatch(late bingding)。then I want call it's property or method,it's fail。
but it's ok use c#.
How to use use late binding to get excel instance?
the code like this.
function GetProperty(dispobj: IDispatch; PropertyName: widestring;
var retvalue: IDispatch): Boolean;
var
hr: HResult;
DispId1: Integer;
value: Variant;
params: TDispParams;
begin
Result := false;
hr := dispobj.GetIDsOfNames(GUID_NULL, #(PropertyName), 1,
LOCALE_SYSTEM_DEFAULT, #DispId1);
if (hr >= 0) then begin
hr := dispobj.Invoke(DispId1, GUID_NULL, LOCALE_SYSTEM_DEFAULT,
DISPATCH_PROPERTYGET, params, #value, nil, nil);
if (hr >= 0) then begin
retvalue := value;
Result := true;
end;
end;
end;
hWindow := GetWordHandle(Trim(LabeledEdit1.Text));
hWindow := GetChildWndHandle(hWindow, '_WwG');
if `AccessibleObjectFromWindow`(hWindow, 0, IID_IDispatch, WordObject) = S_OK then begin
//GetProperty(WordObject, 'Application', WordApp);
// WordObject.GetTypeInfoCount(nCount);
//Showmessage(IntToStr(nCount));
//WordApplication1.ConnectTo((WordObject.Application) as _Application);
// Showmessage(WordObject.Application.Version)
OleCheck(WordObject.QueryInterface(IID_IDispatch, WordApp));
WordApplication1.ConnectTo(IDispatch(WordApp) as _Application);
Showmessage(WordApplication1.Version)
end
#David Heffernan the full code:
procedure TMainForm.Button3Click(Sender: TObject);
var
WordObject: IDispatch; // IDispatch;
hWindow: hWnd;
iWordApp: IDispatch;
WordApp: _Application;
begin
hWindow := GetWordHandle(Trim(LabeledEdit1.Text));
hWindow := GetChildWndHandle(hWindow, '_WwG');
if AccessibleObjectFromWindow(hWindow, 0, IID_IDispatch, WordObject) = S_OK
then
begin
OleCheck(WordObject.QueryInterface(IID_IDispatch, iWordApp));
WordApp := (iWordApp) as _Application; // <--- interface not supported
WordApplication1.ConnectTo(WordApp);
Showmessage(WordApplication1.Version)
end
end;
is translated from C# code。
How to use use late binding to get excel instance?

Network infrastructure discovery

I would like to perform a thorough LAN devices discovery, so that I can create a diagram similar to the one attached, but with additional information like IP and MAC addresses.
I've tried the code from Torry:
type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..100] of TNetResource;
function CreateNetResourceList(ResourceType: DWord;
NetResource: PNetResource;
out Entries: DWord;
out List: PNetResourceArray): Boolean;
var
EnumHandle: THandle;
BufSize: DWord;
Res: DWord;
begin
Result := False;
List := Nil;
Entries := 0;
if WNetOpenEnum(RESOURCE_GLOBALNET,
ResourceType,
0,
NetResource,
EnumHandle) = NO_ERROR then begin
try
BufSize := $4000; // 16 kByte
GetMem(List, BufSize);
try
repeat
Entries := DWord(-1);
FillChar(List^, BufSize, 0);
Res := WNetEnumResource(EnumHandle, Entries, List, BufSize);
if Res = ERROR_MORE_DATA then
begin
ReAllocMem(List, BufSize);
end;
until Res <> ERROR_MORE_DATA;
Result := Res = NO_ERROR;
if not Result then
begin
FreeMem(List);
List := Nil;
Entries := 0;
end;
except
FreeMem(List);
raise;
end;
finally
WNetCloseEnum(EnumHandle);
end;
end;
end;
procedure ScanNetworkResources(ResourceType, DisplayType: DWord; List: TStrings);
procedure ScanLevel(NetResource: PNetResource);
var
Entries: DWord;
NetResourceList: PNetResourceArray;
i: Integer;
begin
if CreateNetResourceList(ResourceType, NetResource, Entries, NetResourceList) then try
for i := 0 to Integer(Entries) - 1 do
begin
if (DisplayType = RESOURCEDISPLAYTYPE_GENERIC) or
(NetResourceList[i].dwDisplayType = DisplayType) then begin
List.AddObject(NetResourceList[i].lpRemoteName,
Pointer(NetResourceList[i].dwDisplayType));
end;
if (NetResourceList[i].dwUsage and RESOURCEUSAGE_CONTAINER) <> 0 then
ScanLevel(#NetResourceList[i]);
end;
finally
FreeMem(NetResourceList);
end;
end;
begin
ScanLevel(Nil);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ScanNetworkResources(RESOURCETYPE_DISK, RESOURCEDISPLAYTYPE_SERVER, ListBox1.Items);
end;
But it only returns the names of the computers in the network, without the router and their IP address. So that's not really a solution.
Could you please tell me what is a good way to enumerate all devices (routers, computers, printers) in a local network, along with their IP and MAC addresses?
Thank you.
I modified you code adding the function GetHostName and inet_ntoa to get the ip address and the SendARP function to get the MAC address of a network resource.
{$APPTYPE CONSOLE}
{$R *.res}
uses
StrUtils,
Windows,
WinSock,
SysUtils;
type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..1023] of TNetResource;
function SendArp(DestIP,SrcIP:ULONG;pMacAddr:pointer;PhyAddrLen:pointer) : DWord; StdCall; external 'iphlpapi.dll' name 'SendARP';
function GetIPAddress(const HostName: AnsiString): AnsiString;
var
HostEnt: PHostEnt;
Host: AnsiString;
SockAddr: TSockAddrIn;
begin
Result := '';
Host := HostName;
if Host = '' then
begin
SetLength(Host, MAX_PATH);
GetHostName(PAnsiChar(Host), MAX_PATH);
end;
HostEnt := GetHostByName(PAnsiChar(Host));
if HostEnt <> nil then
begin
SockAddr.sin_addr.S_addr := Longint(PLongint(HostEnt^.h_addr_list^)^);
Result := inet_ntoa(SockAddr.sin_addr);
end;
end;
function GetMacAddr(const IPAddress: AnsiString; var ErrCode : DWORD): AnsiString;
var
MacAddr : Array[0..5] of Byte;
DestIP : ULONG;
PhyAddrLen : ULONG;
begin
Result :='';
ZeroMemory(#MacAddr,SizeOf(MacAddr));
DestIP :=inet_addr(PAnsiChar(IPAddress));
PhyAddrLen:=SizeOf(MacAddr);
ErrCode :=SendArp(DestIP,0,#MacAddr,#PhyAddrLen);
if ErrCode = S_OK then
Result:=AnsiString(Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x',[MacAddr[0], MacAddr[1],MacAddr[2], MacAddr[3], MacAddr[4], MacAddr[5]]));
end;
function ParseRemoteName(Const lpRemoteName : string) : string;
begin
Result:=lpRemoteName;
if StartsStr('\\', lpRemoteName) and (Length(lpRemoteName)>2) and (LastDelimiter('\', lpRemoteName)>2) then
Result:=Copy(lpRemoteName, 3, PosEx('\', lpRemoteName,3)-3)
else
if StartsStr('\\', lpRemoteName) and (Length(lpRemoteName)>2) and (LastDelimiter('\', lpRemoteName)=2) then
Result:=Copy(lpRemoteName, 3, length(lpRemoteName));
end;
function CreateNetResourceList(ResourceType: DWord;
NetResource: PNetResource;
out Entries: DWord;
out List: PNetResourceArray): Boolean;
var
EnumHandle: THandle;
BufSize: DWord;
Res: DWord;
begin
Result := False;
List := Nil;
Entries := 0;
if WNetOpenEnum(RESOURCE_GLOBALNET, ResourceType, 0, NetResource, EnumHandle) = NO_ERROR then
begin
try
BufSize := $4000; // 16 kByte
GetMem(List, BufSize);
try
repeat
Entries := DWord(-1);
FillChar(List^, BufSize, 0);
Res := WNetEnumResource(EnumHandle, Entries, List, BufSize);
if Res = ERROR_MORE_DATA then
begin
ReAllocMem(List, BufSize);
end;
until Res <> ERROR_MORE_DATA;
Result := Res = NO_ERROR;
if not Result then
begin
FreeMem(List);
List := Nil;
Entries := 0;
end;
except
FreeMem(List);
raise;
end;
finally
WNetCloseEnum(EnumHandle);
end;
end;
end;
procedure ScanNetworkResources(ResourceType, DisplayType: DWord);
procedure ScanLevel(NetResource: PNetResource);
var
Entries: DWord;
NetResourceList: PNetResourceArray;
i: Integer;
IPAddress, MacAddress : AnsiString;
ErrCode : DWORD;
begin
if CreateNetResourceList(ResourceType, NetResource, Entries, NetResourceList) then try
for i := 0 to Integer(Entries) - 1 do
begin
if (DisplayType = RESOURCEDISPLAYTYPE_GENERIC) or
(NetResourceList[i].dwDisplayType = DisplayType) then
begin
IPAddress :=GetIPAddress(ParseRemoteName(AnsiString(NetResourceList[i].lpRemoteName)));
MacAddress :=GetMacAddr(IPAddress, ErrCode);
Writeln(Format('Remote Name %s Ip %s MAC %s',[NetResourceList[i].lpRemoteName, IPAddress, MacAddress]));
end;
if (NetResourceList[i].dwUsage and RESOURCEUSAGE_CONTAINER) <> 0 then
ScanLevel(#NetResourceList[i]);
end;
finally
FreeMem(NetResourceList);
end;
end;
begin
ScanLevel(Nil);
end;
var
WSAData: TWSAData;
begin
try
if WSAStartup($0101, WSAData)=0 then
try
ScanNetworkResources(RESOURCETYPE_ANY, RESOURCEDISPLAYTYPE_SERVER);
Writeln('Done');
finally
WSACleanup;
end;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
Readln;
end.

Resources