I'm using the WorkerThread from DelphiPraxis with Delphi XE2.
http://www.delphipraxis.net/93835-workerthread-der-diener-im-hintergrund.html
In my JobThread, I'm loading a DLL, which does some waiting (for Testing..)
function DLLClass.doStuff(): boolean;
var
I: integer;
begin
try
for I := 0 to 100 do
begin
sleep(10);
if (assigned(StatusCallback)) then
StatusCallback(PWideChar(I));
end;
Result := true;
except
on e: exception do
begin
error := 'DLL FEHLER: ' + e.ClassName + ' - ' + e.Message;
Result := false;
end;
end;
end;
The "StatusCallback" is a Reference to a procedure in the Thread whichis loading the DLL:
TStatusUpdate = procedure(Status: PWideChar) of object; stdcall;
My Callback looks like this:
procedure JobThread.statuscall(status: pwidechar); stdcall;
begin
//saving the Status in a global Variable..
if Assigned(OnStatus) then
fThread.Synchronize(syncStatus);
end;
Which calls:
procedure JobThread.syncStatus;
begin
if Assigned(OnStatus) then
begin
OnStatus(self);
end;
end; //<- AV here!
OnStatus eventhandler:
Procedure TfMain.uploadStatus(aJob: TWorkerThreadJob);
begin
//doing nothing.. yet an AV
sleep(10);
end;
I think the problem is somehow related to the DLL not being able to Synchronize with the MainThread.
Any ideas on working around the Synchronize (if it's actually the problem)?
Related
I make an application where the client and the server are in the same program. I use Delphi XE7 and components TIpTCPServer / ... Client. But when I try to close the server with the client connected (in the same window), the program stops responding. Perhaps this is something related to multithreading. How to implement a program with a client and server in one application and is this the right approach?
procedure TfrmMain.startClick(Sender: TObject);
begin
if (server.active) then stopServer()
else startServer();
end;
procedure TfrmMain.startServer();
var
binding: TIdSocketHandle;
begin
server.bindings.clear();
try
server.defaultPort := strToInt(port.text);
binding := server.bindings.add();
binding.ip := ip;
binding.port := strToInt(port.text);
server.active := true;
if (server.active) then begin
addToLog('Server started');
start.caption := 'Stop';
end;
except on e: exception do
addToLog('Error: ' + e.message + '.');
end;
end;
procedure TfrmMain.stopServer();
begin
server.active := false;
server.bindings.clear();
if (not(server.active)) then begin
addToLog('Server stopped');
start.caption := 'Start';
end
else addToLog('Server shutdown error.');
end;
procedure TfrmMain.serverConnect(AContext: TIdContext);
var
i: integer;
begin
addToLog('New client: ' + aContext.connection.socket.binding.peerIP + '.');
clients.clear();
for i := 0 to server.contexts.lockList.count - 1 do begin
with TIdContext(server.contexts.lockList[i]) do
clients.items.add(connection.socket.binding.peerIP);
end;
server.contexts.unlockList();
end;
procedure TfrmMain.serverDisconnect(AContext: TIdContext);
begin
addToLog('Client ' + aContext.connection.socket.binding.peerIP + ' disconnected from the server.');
end;
procedure TfrmMain.clientConnected(Sender: TObject);
begin
addToConsole('You connected to server successfully.');
end;
procedure TfrmMain.clientDisconnected(Sender: TObject);
begin
addToConsole('The connection to the server was interrupted.');
end;
and connection code:
client.host := ip;
try
client.connect();
except on e: exception do
addToConsole('Error: ' + e.message);
end;
I see a number of issues with this code.
How are addToLog() and addToConsole() implemented? Are they thread-safe? Remember that TIdTCPServer is a multi-threaded component, its events are fired in the context of worker threads, not the main UI thread, so any access to the UI, shared variables, etc must be synchronized.
What is clients? Is it is a UI control? You need to sync access to it so you don't corrupt its content when multiple threads try to access it at the same time.
Your use of the TIdTCPServer.Contexts property is not adequately protected from exceptions. You need a try..finally block so you can call Contexts.UnlockList() safely.
More importantly, you are calling Contexts.LockList() too many times in your serverConnect() loop (this is the root cause of your problem). LockList() returns a TIdContextList object. Inside your loop, you should be accessing that list's Items[] property instead of calling LockList() again. Because you do not have a matching UnlockList() for each LockList(), once a client connects to your server, the Contexts list becomes deadlocked, and can no longer be accessed once serverConnect() exits, which includes when clients connect/disconnect, and during TIdTCPServer shutdown (such as in your case).
serverDisconnect() is not removing any items from clients. serverConnect() should not be resetting clients at all. It should add only the calling TIdContext to clients, and then serverDisconnect() should remove that same TIdContext from clients later.
With that said, try something more like this:
procedure TfrmMain.addToConsole(const AMsg: string);
begin
TThread.Queue(nil,
procedure
begin
// add AMsg to console ...
end
);
end;
procedure TfrmMain.addToLog(const AMsg: string);
begin
TThread.Queue(nil,
procedure
begin
// add AMsg to log ...
end
);
end;
procedure TfrmMain.startClick(Sender: TObject);
begin
if server.Active then
stopServer()
else
startServer();
end;
procedure TfrmMain.startServer();
var
binding: TIdSocketHandle;
begin
server.Bindings.Clear();
try
server.DefaultPort := StrToInt(port.Text);
binding := server.Bindings.Add();
binding.IP := ip;
binding.Port := StrToInt(port.Text);
server.Active := True;
addToLog('Server started');
start.Caption := 'Stop';
except
on e: Exception do
addToLog('Error: ' + e.message + '.');
end;
end;
procedure TfrmMain.stopServer();
begin
try
server.Active := False;
server.Bindings.Clear();
addToLog('Server stopped');
start.Caption := 'Start';
except
on e: Exception do
addToLog('Server shutdown error.');
end;
end;
procedure TfrmMain.serverConnect(AContext: TIdContext);
var
PeerIP: string;
begin
PeerIP := AContext.Binding.PeerIP;
addToLog('New client: ' + PeerIP + '.');
TThread.Queue(nil,
procedure
{
var
i: integer;
list: TIdContextList;
}
begin
{
clients.clear();
list := server.Contexts.LockList;
try
for i := 0 to list.count - 1 do begin
clients.Items.Add(TIdContext(list[i]).Binding.PeerIP);
end;
finally
list.UnlockList();
end;
}
// I'm assuming clients is a UI control whose Items property
// is a TStrings object. If not, adjust this code as needed...
clients.Items.AddObject(PeerIP, AContext);
end;
);
end;
procedure TfrmMain.serverDisconnect(AContext: TIdContext);
begin
addToLog('Client ' + AContext.Binding.PeerIP + ' disconnected from the server.');
TThread.Queue(nil,
procedure
var
i: Integer;
begin
// I'm assuming clients is a UI control whose Items property
// is a TStrings object. If not, adjust this code as needed...
i := clients.Items.IndexOfObject(AContext);
if i <> -1 then
clients.Items.Delete(i);
end
);
end;
procedure TfrmMain.clientConnected(Sender: TObject);
begin
addToConsole('You connected to server successfully.');
end;
procedure TfrmMain.clientDisconnected(Sender: TObject);
begin
addToConsole('The connection to the server was interrupted.');
end;
I have a simple class that has the following interface implementation.
Note: TPolyBase is an abstract class and TPolyResult is an array of double; it's not important to see their code, it's not relevant here.
//INTERFACE
type
TPolynomialList = class
strict private
FPolynomialList: TObjectList<TPolyBase>;
FResult: TList<TPolyResult>;
FCanGet: boolean;
function GetResult: TList<TPolyResult>;
procedure DoSolve;
public
constructor Create(PolynomialList: TObjectList<TPolyBase>);
destructor Destroy; override;
procedure SolvePolynomials(CompletionHandler: TProc);
property Solutions: TList<TPolyResult> read GetResult;
end;
//IMPLEMENTATION
constructor TPolynomialList.Create(PolynomialList: TObjectList<TPolyBase>);
begin
FPolynomialList := PolynomialList;
FResult := TList<TPolyResult>.Create;
FCanGet := false;
end;
destructor TPolynomialList.Destroy;
begin
FResult.Free;
inherited;
end;
procedure TPolynomialList.DoSolve;
var
i: integer;
begin
for i := 0 to FPolynomialList.Count - 1 do
FResult.Add(FPolynomialList[i].GetSolutions);
FCanGet := true;
end;
function TPolynomialList.GetResult: TList<TPolyResult>;
begin
if FCanGet = false then
raise TEquationError.Create('You must solve the equation first!');
Result := FResult;
end;
procedure TPolynomialList.SolvePolynomials(CompletionHandler: TProc);
begin
TTask.Run(procedure
var
ex: TObject;
begin
try
DoSolve;
TThread.Synchronize(nil, procedure
begin
CompletionHandler;
end);
except
on E: Exception do
begin
ex := AcquireExceptionObject;
TThread.Synchronize(nil, procedure
begin
Writeln( (ex as Exception).Message );
end);
end;
end;
end);
end;
This class takes a list of objects as input and it has an internal important field called FResult that gives the results to the user. It can be accessed from the getter only if the method SolvePolynomials has finished his work.
The problem is in the SolvePolynomials. The code I have shown uses a task because the size of the object list may be very big and I don't want to freeze the UI. Why do I always get an access violation in the task code?
Note that the following code works fine but this is not what I want because if I input 15000 the program freezes for a few seconds.
procedure TPolynomialList.SolvePolynomials(CompletionHandler: TProc);
begin
DoSolve;
CompletionHandler;
end;
Could the FPolynomialList variable be a the problem? If you look at my class the only thing "taken from outside" is the TObjectList<TPolyBase> because in the constructor I simply assing the reference (I'd like to avoid the copy ok 15k items). All the other variables are not shared with anything.
I have seen in many books I have read like "Delphi High Performance" that is good to have a task that calls an inner "slow" method but in this case there could be those reference that are messing up something. Any idea?
This is the code that I am using as test:
var
a: TObjectList<TPolyBase>;
i, j: integer;
f: TPolynomialList;
s: string;
function GetRandom: integer;
begin
Result := (Random(10) + 1);
end;
begin
a := TObjectList<TPolyBase>.Create(true);
try
for i := 0 to 15000 do
begin
a.Add({*Descendant of TPolyBase*})
end;
f := TPolynomialList.Create(a);
try
f.SolvePolynomials(procedure
var
i, j: integer;
begin
for i := 0 to f.Solutions.Count - 1 do
begin
for j := Low(f.Solutions[i]) to High(f.Solutions[i]) do
Writeln({output the results...})
end;
end);
finally
f.Free;
end;
finally
a.Free;
end;
end.
Your SolvePolynomials method delegates solving to another thread and returns before that thread is finished with its task. While that task thread is running it is necessary that all data it operates on is still alive. But, in your code you are releasing necessary object instances right after SolvePolynomials exits - while your task is still running, hence the error.
You have to move releasing of those objects into completion handler.
Basically, your code simplified looks like:
type
TPolynomialList = class
public
destructor Destroy; override;
procedure DoSolve;
procedure SolvePolynomials(CompletionHandler: TProc);
end;
destructor TPolynomialList.Destroy;
begin
Writeln('Destroyed');
inherited;
end;
procedure TPolynomialList.DoSolve;
begin
Writeln('Solving');
end;
procedure TPolynomialList.SolvePolynomials(CompletionHandler: TProc);
begin
TTask.Run(
procedure
begin
try
DoSolve;
TThread.Synchronize(nil,
procedure
begin
CompletionHandler;
end);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end);
end;
procedure Test;
var
f: TPolynomialList;
begin
f := TPolynomialList.Create;
try
f.SolvePolynomials(
procedure
begin
Writeln('Solved');
end);
finally
f.Free;
end;
end;
If you run it output will be:
Destroyed
Solving
Solved
However, if you move releasing of your variables into completion handler order of execution will be correct.
procedure Test;
var
f: TPolynomialList;
begin
f := TPolynomialList.Create;
f.SolvePolynomials(
procedure
begin
Writeln('Solved');
f.Free;
end);
end;
Solving
Solved
Destroyed
For your code, that means moving both a.Free and f.Free into completion handler.
Can anyone tell me why this code is leading to my application to stop responding.
My application calls a COM library. I wait for the COM library events to fire so that I can carry on.
I use a timer to keep checking if the COM library fired:
procedure MyTimer(hWnd: HWND; uMsg: Integer; idEvent: Integer; dwTime: Integer); stdcall;
begin
//writeln('Timer Event');
end;
I keep checking if the event fired this way:
procedure MyClass.Loop(bwait: boolean);
var
s: TDateTime;
id: uint;
begin
try
id := SetTimer(0, 1, 1000, #MyTimer);
s := Now;
while bwait do
begin
sleep(30);
Application.ProcessMessages;
if bwait = false then // Event fired, all good=> exit
begin
KillTimer(0, id);
break;
end;
if Now - s > EncodeTime(0, 0, 1000, 0) then // Timed out=> exit
begin
KillTimer(0, id);
break;
end;
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end;
When the COM library event fires it sets the bwait boolean variable to true which means all good and we can exit and carry on.
If event hasn't fired within a certain time then I exit & inform user.
This code sometimes creates thread locks.
My application and the COM library stop responding.
What's causing the lock ?
How can the above code be improved ?
Thank you.
The whole purpose of events is to NOT write synchronous blocking code.
Application.ProcessMessages() is not intended to process COM messages. You can use TEvent instead, which has a UseCOMWait parameter to make the TEvent.WaitFor() method use CoWaitForMultipleHandles() internally to process the COM message loop while waiting for the event to be signaled.
uses
..., DateUtils, SyncObjs;
type
MyClass = class
private
doneEvent: TEvent;
procedure COMEventHandler(parameters);
procedure Loop(bWait: Boolean);
...
public
constructor Create;
destructor Destroy; override;
procedure DoIt;
end;
constructor MyClass.Create;
begin
inherited;
...
doneEvent := TEvent.Create(True);
end;
destructor MyClass.Destroy;
begin
...
doneEvent.Free;
inherited;
end;
procedure MyClass.COMEventHandler(parameters);
begin
doneEvent.SetEvent;
end;
procedure MyClass.Loop(bWait: Boolean);
var
s: TDateTime;
begin
if not bWait then Exit;
try
s := Now;
repeat
case doneEvent.WaitFor(30) of
wrSignaled: begin
// Event fired, all good=> exit
Break;
end;
wrTimeout: begin
if MillisecondsBetween(Now, s) > (1000 * 1000) then
begin
// Timed out=> exit
Break;
end;
if GetQueueStatus(QS_ALLINPUT) <> 0 then
Application.ProcessMessages;
end;
wrError: begin
RaiseLastOSError(doneEvent.LastError);
end;
end;
until False;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end;
procedure MyClass.DoIt;
begin
doneEvent.ResetEvent;
// invoke COM function that will eventually trigger the COM event...
Loop(True); // wait for event to fire or timer to elapse...
...
end;
But this is not the correct way to write event-driven code. Like any asynchronous system, you should break up your code into smaller pieces and let the events notify your code when to invoke those pieces. Don't write blocking code at all. For example:
const
APPWM_COM_EVENT_DONE = WM_APP + 1;
APPWM_COM_EVENT_TIMEOUT = WM_APP + 2;
type
MyClass = class
private
MsgWnd: HWND;
procedure COMEventHandler(parameters);
procedure WndProc(var Message: TMessage);
public
constructor Create;
destructor Destroy; override;
procedure DoIt;
end;
constructor MyClass.Create;
begin
inherited;
MsgWnd := AllocateHWnd(WndProc);
end
destructor MyClass.Destroy;
begin
KillTimer(MsgWnd, 1);
DeallocateHWnd(MsgWnd);
inherited;
end;
procedure MyClass.COMEventHandler(parameters);
begin
KillTimer(MsgWnd, 1);
PostMessage(MsgWnd, APPWM_COM_EVENT_DONE, 0, 0);
end;
procedure MyTimer(hWnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
begin
KillTimer(hWnd, idEvent);
PostMessage(hWnd, APPWM_COM_EVENT_TIMEOUT, 0, 0);
end;
procedure MyClass.WndProc(var Message: TMessage);
begin
case Message.Msg of
APPWM_COM_EVENT_DONE:
begin
// Event fired, all good
end;
APPWM_COM_EVENT_TIMEOUT:
begin
// Event timed out
end;
else
begin
Message.Result := DefWindowProc(MsgWnd, Message.Msg, Message.WParam, Message.LParam);
end;
end;
end;
procedure MyClass.DoIt;
begin
SetTimer(MsgWnd, 1, 1000 * 1000, #MyTimer);
// invoke COM function that will eventually trigger the COM event...
// exit now, let WndProc() handle the notifications later...
end;
I created an HTTP server with Delphi. To test the server response time I created an http client application which generates random urls. The problem is when I start sending requests to the server part of them are being processed. Here is part of my code:
This procedure is being executed to start sending requests:
procedure TPerformanceTestForm.ExecuteURLs;
var
requests: array of TRequestBuilder;
i: Integer;
Stopwatch: TStopwatch;
Elapsed: TTimeSpan;
begin
SetLength(requests, 10);
EnterCriticalSection(criticalSection);
Stopwatch := TStopwatch.StartNew;
for i := 0 to Length(requests) - 1 do
begin
requests[i] := TRequestBuilder.Create;
end;
// remove this lines from source in order to execute all threads
// for i := 0 to Length(requests) - 1 do
// begin
// requests[i].Terminate;
// end;
Elapsed := Stopwatch.Elapsed;
Seconds := Elapsed.TotalSeconds;
LeaveCriticalSection(criticalSection);
end;
procedure TPerformanceTestForm.btnStopQueriesClick(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Length(requests) - 1 do
begin
// requests[i].WaitFor; // the program crashes
requests[i].Free;
end;
end;
This is part of TRequestBuilder class:
TRequestBuilder = class(TThread)
private
fHttpClient: TIdHTTP;
public
Constructor Create; reintroduce;
procedure Execute; override;
end;
Constructor TRequestBuilder.Create;
begin
inherited Create(False); // in order not to start another loop and call start for each instance
// FreeOnTerminate := True; // removed this line; see the first answer to know why
Self.fHttpClient := TIdHTTP.Create;
// HttpWorkBegin and HttWork I get from the first answer
Self.fHttpClient.OnWorkBegin := HttpWorkBegin;
Self.fHttpClient.OnWork := HttpWork;
end;
procedure TRequestBuilder.Execute;
var
request, response: string;
begin
repeat
try
request := GenerateHttpRequest;
response := Self.fHttpClient.Get(request);
log.AddJob(request + ' ---> ' + response + ' ---> ' +
FormatDateTime('dd.mm.yyyy hh:mm:ss', Now));
except
on e: Exception do
begin
errlog.Add(FormatDateTime('dd.mm.yyyy hh:mm:ss', Now) + ' ---> ' +
e.Message);
end;
end;
until (Terminated);
end;
// EDIT: change Execute procedure to avoid socket errors (removed the httpClient from class variables):
procedure TRequestBuilder.Execute;
var
request, response: string;
httpClient: TIdHTTP;
begin
repeat
try
httpClient := TIdHTTP.Create;
try
request := GenerateHttpRequest;
response := httpClient.Get(request);
log.AddJob(request + ' ---> ' + response + ' ---> ' +
FormatDateTime('dd.mm.yyyy hh:mm:ss', Now));
finally
httpClient.Free;
end;
except
on e: Exception do
begin
errlog.Add(FormatDateTime('dd.mm.yyyy hh:mm:ss', Now) + ' ---> ' +
e.Message);
end;
end;
until (Terminated);
end;
**EDIT: ** When I stop the http client I get this error: Access violation at address 004083A0 in module App.exe. Read of address FFFFFFFC.
**EDIT: ** I removed the second for loop in ExecutreURLs and now the program works fine (sometimes the exception is raised). My question now is: is the program leaking memory when I don't terminate the requests in ExecuteURLs procedure?
**EDIT: ** When I remove the repeat- until loop from the Execute procedure the program works fine (only the exception in the first edit is thrown). When I add the repeat- until loop and remove from btnStopQueries onclick event I get several socket errors
Calling TThread.Terminate() merely sets the TThread.Terminated property and does nothing else. It does not actually terminate the thread. A thread is responsible for checking Terminated periodically and then exiting from Execute() when needed. You are not using the Terminated property anywhere in your code, so calling Terminate() is useless in your example.
You are setting FreeOnTerminate=True in your threads. So no, you are not leaking the threads by not calling Terminate(). They will free themselves after TIdHTTP has finished its work.
Your Access Violation is most likely due to one or more of the threads simply terminating and freeing themselves from memory before you have a chance to call Terminate() on them. The rule of thumb for using FreeOnTerminate is that if you need to access a thread object from outside of the thread's own code (such as you are doing by tracking the threads and calling Terminate() on them) then DO NOT use FreeOnTerminate=True at all! The TThread object could disappear from memory at ANY moment. Your only saving grace in that situation is if you use the TThread.OnTerminate event to be notified when a FreeOnTerminate thread terminates. That event is fired before the thread frees itself. Otherwise, leave FreeOnTerminate=False and manually free the thread object when you are done using it.
A safer approach would look more like this instead:
procedure TPerformanceTestForm.ExecuteURLs;
var
requests: array of TRequestBuilder;
i: Integer;
Stopwatch: TStopwatch;
Elapsed: TTimeSpan;
begin
SetLength(requests, 10);
Stopwatch := TStopwatch.StartNew;
for i := 0 to Length(requests) - 1 do
begin
requests[i] := TRequestBuilder.Create;
end;
// optional, maybe after a timeout...
{
for i := 0 to Length(requests) - 1 do
begin
requests[i].Terminate;
end;
}
for i := 0 to Length(requests) - 1 do
begin
requests[i].WaitFor;
requests[i].Free;
end;
Elapsed := Stopwatch.Elapsed;
Seconds := Elapsed.TotalSeconds;
end;
TRequestBuilder = class(TThread)
private
fHttpClient: TIdHTTP;
procedure HttpWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64);
procedure HttpWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
protected
procedure Execute; override;
public
constructor Create; reintroduce;
destructor Destroy; override;
end;
constructor TRequestBuilder.Create;
begin
inherited Create(False);
fHttpClient := TIdHTTP.Create;
fHttpClient.OnWorkBegin := HttpWorkBegin;
fHttpClient.OnWork := HttpWork;
end;
destructor TRequestBuilder.Destroy;
begin
fHttpClient.Free;
inherited Destroy;
end;
procedure TRequestBuilder.HttpWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64);
begin
if Terminated then SysUtils.Abort;
end;
procedure TRequestBuilder.HttpWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
begin
if Terminated then SysUtils.Abort;
end;
procedure TRequestBuilder.Execute;
var
request, response: string;
begin
request := 'http://localhost/?command=validcommand¶m=value';
response := fHttpClient.Get(request);
// log source: http://stackoverflow.com/questions/26099961/asynchronous-append-to-txt-file-in-delphi
log.AddJob(request + ' ---> ' + response);
end;
I am trying to register an Active X .ocx Library in a Delphi program i have tried the following code with out success no errors and the program runs through all of the code but when it has finished the Active X Library hasn't been registered. What am i doing wrong ?
procedure RegisterOCX;
type
TRegFunc = function : HResult; stdcall;
var
ARegFunc : TRegFunc;
aHandle : THandle;
ocxPath,AppPath : string;
begin
GetDir(0, AppPath);
try
ocxPath := AppPath + '\VOIP.ocx';
aHandle := LoadLibrary(PChar(ocxPath));
if aHandle <> 0 then
begin
ARegFunc := GetProcAddress(aHandle,'DllRegisterServer');
if Assigned(ARegFunc) then
begin
ExecAndWait('regsvr32','/s ' + ocxPath);
end;
FreeLibrary(aHandle);
end;
except
ShowMessage('Unable to register ');
end;
end;
function ExecAndWait(const ExecuteFile, ParamString : string): boolean;
var
SEInfo: TShellExecuteInfo;
ExitCode: DWORD;
begin
FillChar(SEInfo, SizeOf(SEInfo), 0);
SEInfo.cbSize := SizeOf(TShellExecuteInfo);
with SEInfo do begin
fMask := SEE_MASK_NOCLOSEPROCESS;
Wnd := Application.Handle;
lpFile := PChar(ExecuteFile);
lpParameters := PChar(ParamString);
nShow := SW_HIDE;
end;
if ShellExecuteEx(#SEInfo) then
begin
repeat
Application.ProcessMessages;
GetExitCodeProcess(SEInfo.hProcess, ExitCode);
until (ExitCode <> STILL_ACTIVE) or Application.Terminated;
Result:=True;
end
else Result:=False;
end;
You are making life hard for yourself by using regsvr32. You've gone 99% of the way to doing without. Instead of calling regsvr32, just call DllRegisterServer. After all, that's all that regsvr32 is going to do!
Your code becomes:
if Assigned(ARegFunc) then
OleCheck(ARegFunc());
You can then remove ExecAndWait altogether. Which is nice because it saves me discussing the busy loop, and the leaked handle!
It would make sense to me to rename the variable that you called ARegFunc as DllRegisterServer. So the code might then look like this:
aHandle := LoadLibrary(PChar(ocxPath));
if aHandle = 0 then
RaiseLastWin32Error;
try
DllRegisterServer := GetProcAddress(aHandle,'DllRegisterServer');
if Assigned(DllRegisterServer) then
OleCheck(DllRegisterServer());
finally
FreeLibrary(aHandle);
end;
The most likely failure mode for a call to DllRegisterServer will be a failure to run your registration code elevated.
As an aside, LoadLibrary returns HMODULE rather than THandle.