I have a running threading application that is computing some longer calculations.
procedure TForm.calculationInThread(value: Integer);
var aThread : TThread;
begin
aThread :=
TThread.CreateAnonymousThread(
procedure
begin
myCalculation(value);
end
);
aThread.FreeOnTerminate := True;
aThread.OnTerminate := self.calculationInThreadEnd;
aThread.Start;
end;
And an implementation of calculationInThreadEnd;
procedure TForm.calculationInThreadEnd(Sender: TObject);
begin
doSomething;
end;
I may miss just something stupid, but how to pass a value to calculationInThreadEnd? I found
TThread.SetReturnValue(value);
but how do i access that in the onTerminate call?
Solution
type THackThread = class(TThread);
procedure TForm1.calculationInThreadEnd(Sender: TObject);
var Value: Integer;
begin
Value := THackThread(Sender as TThread).ReturnValue;
end;
The Sender parameter of the OnTerminate event is the thread object. So you can do this:
aThread :=
TThread.CreateAnonymousThread(
procedure
begin
myCalculation(value);
TThread.SetReturnValue(...);
end
);
Then in the OnTerminate event handler you can do:
procedure TForm.calculationInThreadEnd(Sender: TObject);
var
Value: Integer;
begin
Value := (Sender as TThread).ReturnValue;
end;
Update
The return value property is protected so you'll need to use the protected hack to gain access to it.
Related
Hi I'm doing a code MessageDlgPos running five threads at the same time, the code is this:
type
TMyThread = class(TThread)
protected
procedure Execute; override;
public
text: string;
property ReturnValue;
end;
procedure TMyThread.Execute;
begin
if Terminated then
Exit;
MessageDlgPos(text, mtInformation, [mbOk], 0, 100, 200);
end;
procedure TForm1.btnTestClick(Sender: TObject);
var
LThread: TMyThread;
i: Integer;
begin
For i := 1 to 5 do
begin
LThread := TMyThread(Sender);
try
LThread.text := 'hi';
LThread.FreeOnTerminate := True;
except
LThread.Free;
raise;
end;
LThread.Resume;
end;
end;
The problem is that Delphi XE always returns the following error and does not execute anything:
First chance exception at $ 7524B727. Exception class EAccessViolation with message 'Access violation at address 00D0B9AB. Write of address 8CC38309 '. Process tester.exe (6300)
How do I fix this problem?
As David Heffernan pointed out, MessageDlgPos() cannot safely be called outside of the main UI thread, and you are not managing the thread correctly. Your code needs to look more like this instead:
type
TMyThread = class(TThread)
protected
procedure Execute; override;
public
text: string;
property ReturnValue;
end;
procedure TMyThread.Execute;
begin
// no need to check Terminated here, TThread already
// does that before calling Execute()...
TThread.Synchronize(nil,
procedure
begin
MessageDlgPos(text, mtInformation, [mbOk], 0, 100, 200);
end
);
end;
procedure TForm1.btnTestClick(Sender: TObject);
var
LThread: TMyThread;
i: Integer;
begin
For i := 1 to 5 do
begin
LThread := TMyThread.Create(True);
LThread.text := 'hi';
LThread.FreeOnTerminate := True;
LThread.Start;
end;
end;
I would suggest a slightly different variation:
type
TMyThread = class(TThread)
private
fText: string;
protected
procedure Execute; override;
public
constructor Create(const aText: string); reintroduce;
property ReturnValue;
end;
constructor TMyThread.Create(const aText: string);
begin
inherited Create(False);
FreeOnTerminate := True;
fText := aText;
end;
procedure TMyThread.Execute;
begin
// no need to check Terminated here, TThread already
// does that before calling Execute()...
TThread.Synchronize(nil,
procedure
begin
MessageDlgPos(fText, mtInformation, [mbOk], 0, 100, 200);
end
);
end;
procedure TForm1.btnTestClick(Sender: TObject);
var
i: Integer;
begin
For i := 1 to 5 do
begin
TMyThread.Create('hi');
end;
end;
But either way, if you don't like using TThread.Synchronize() to delegate to the main thread (thus only displaying 1 dialog at a time) then you cannot use MessageDlgPos() at all, since it is only safe to call in the main UI thread. You can use Windows.MessageBox() instead, which can be safely called in a worker thread without delegation (but then you lose the ability to specify its screen position, unless you access its HWND directly by using a thread-local hook via SetWindowsHookEx() to intercept the dialog's creation and discover its HWND):
procedure TMyThread.Execute;
begin
Windows.MessageBox(0, PChar(fText), PChar(Application.Title), MB_OK or MB_ICONINFORMATION);
);
end;
There are many problems. The biggest one is here:
LThread := TMyThread(Sender);
Sender is a button. Casting to a thread is simply wrong and the cause of your exception. Casting a button to a thread doesn't make it so. It's still a button.
You likely mean to create a thread instead.
LThread := TMyThread.Create(True);
You cannot show VCL UI outside the main thread. The call to MessageDlgPos breaks that rule. If you do need to show UI at that point, you'll need to use TThread.Synchronize to have the code execute in the main thread.
Your exception handler makes no sense to me. I think you should remove it.
Resume is deprecated. Use Start instead.
I'm trying to convert a single thread application to a multi thread application.
Basically, I want to check simultaneously at every 10 seconds,50 ports at once and see if they are online or offline.
I'm using a listbox to load all the ip and ports (127.0.0.1:50008) they I parse the ip and port number and check it using this function:
uses idTCPclient;
function IsPortActive(AHost : string; APort : string): boolean;
var
IdTCPClient : TIdTCPClient;
begin
Result := False;
try
IdTCPClient := TIdTCPClient.Create(nil);
try
IdTCPClient.Host := AHost;
IdTCPClient.Port := strtoint(APort);
IdTCPClient.ConnectTimeout:=50;
IdTCPClient.Connect;
Result := True;
finally
IdTCPClient.Free;
end;
except
//Ignore exceptions
end;
end;
Here is the procedure to start checking the port and signal the result accordingly:
procedure TForm2.Button1Click(Sender: TObject);
begin
if isportactive('127.0.0.1','50008') then
listbox_online.items.add(ip+''+port)
else
listbox_offline.items.add(ip+''+port);
end;
Could someone please guide me how to convert this as a thread that can accept IP and port as parameter?
One way to write the thread can be this one.
I have not added any extra TNotifyEvent methods because you can look for the properties you need in the thread's OnTerminate event.
type
THostChecker = class(TThread)
strict private
FIdTCPClient: TIdTCPClient;
FHost: string;
FPort: Integer;
FConnectTimeout: Integer;
FIsPortActive: Boolean;
protected
procedure Execute; override;
public
constructor Create(const AHost: string; APort: Integer; AConnectTimeout: Integer = 50; CreateSuspended: Boolean = False);
property IsPortActive: Boolean read FIsPortActive;
property Host: string read FHost;
property Port: Integer read FPort;
destructor Destroy; override;
end;
implementation
{ THostChecker}
constructor THostChecker.Create(const AHost: string; APort: Integer; AConnectTimeout: Integer; CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
FHost := AHost;
FPort := APort;
FConnectTimeout := AConnectTimeout;
FIdTCPClient := TIdTCPClient.Create(nil);
FIsPortActive := False;
end;
destructor THostChecker.Destroy;
begin
FIdTCPClient.Free;
inherited;
end;
procedure THostChecker.Execute;
begin
inherited;
with FIdTCPClient do begin
Host := FHost;
Port := FPort;
ConnectTimeout := FConnectTimeout;
Connect;
FIsPortActive := True;
end;
end;
Here's the form relevant parts:
procedure TForm4.Button1Click(Sender: TObject);
const
hosts: array [0..6] of string = ('google.com', 'stackoverflow.com', 'youtube.com', 'foo.org', 'null.org', 'porn.com', 'microsoft.com');
var
i: Integer;
begin
for i:=Low(hosts) to High(hosts) do
with THostChecker.Create(hosts[i], 80, 50, False) do begin
OnTerminate := HostCheckerTerminate;
FreeOnTerminate := True;
end;
end;
procedure TForm4.HostCheckerTerminate(Sender: TObject);
var
hostChecker: THostChecker;
ex: Exception;
hostAndPort: string;
begin
hostChecker := THostChecker(Sender);
ex := Exception(hostChecker.FatalException);
if Assigned(ex) then
//do something useful here or don't evaluate ex at all
hostAndPort := Format('%s:%d', [hostChecker.Host, hostChecker.Port]);
if hostChecker.IsPortActive then
listbox_online.items.add(hostAndPort)
else
listbox_offline.items.add(hostAndPort);
end;
The property FreeOnTerminate is set to True in order to avoid the call to Free for the thread itself.
The code which is executed in the OnTerminate event of a thread is already synchronized in the calling thread.
The threads do not raise exceptions in the calling tread but you can check if an exception has occurred in the Execute method evaluating the FatalException property in the OnTerminate event.
I am designing a thread pool with following features.
New thread should be spawned only when all other threads are running.
Maximum number of thread should be configurable.
When a thread is waiting, it should be able to handle new requests.
Each IO operation should call a callback on completion
Thread should have a way to manage request its serving and IO callbacks
Here is the code:
unit ThreadUtilities;
interface
uses
Windows, SysUtils, Classes;
type
EThreadStackFinalized = class(Exception);
TSimpleThread = class;
// Thread Safe Pointer Queue
TThreadQueue = class
private
FFinalized: Boolean;
FIOQueue: THandle;
public
constructor Create;
destructor Destroy; override;
procedure Finalize;
procedure Push(Data: Pointer);
function Pop(var Data: Pointer): Boolean;
property Finalized: Boolean read FFinalized;
end;
TThreadExecuteEvent = procedure (Thread: TThread) of object;
TSimpleThread = class(TThread)
private
FExecuteEvent: TThreadExecuteEvent;
protected
procedure Execute(); override;
public
constructor Create(CreateSuspended: Boolean; ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
end;
TThreadPoolEvent = procedure (Data: Pointer; AThread: TThread) of Object;
TThreadPool = class(TObject)
private
FThreads: TList;
fis32MaxThreadCount : Integer;
FThreadQueue: TThreadQueue;
FHandlePoolEvent: TThreadPoolEvent;
procedure DoHandleThreadExecute(Thread: TThread);
procedure SetMaxThreadCount(const pis32MaxThreadCount : Integer);
function GetMaxThreadCount : Integer;
public
constructor Create( HandlePoolEvent: TThreadPoolEvent; MaxThreads: Integer = 1); virtual;
destructor Destroy; override;
procedure Add(const Data: Pointer);
property MaxThreadCount : Integer read GetMaxThreadCount write SetMaxThreadCount;
end;
implementation
constructor TThreadQueue.Create;
begin
//-- Create IO Completion Queue
FIOQueue := CreateIOCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0);
FFinalized := False;
end;
destructor TThreadQueue.Destroy;
begin
//-- Destroy Completion Queue
if (FIOQueue = 0) then
CloseHandle(FIOQueue);
inherited;
end;
procedure TThreadQueue.Finalize;
begin
//-- Post a finialize pointer on to the queue
PostQueuedCompletionStatus(FIOQueue, 0, 0, Pointer($FFFFFFFF));
FFinalized := True;
end;
function TThreadQueue.Pop(var Data: Pointer): Boolean;
var
A: Cardinal;
OL: POverLapped;
begin
Result := True;
if (not FFinalized) then
//-- Remove/Pop the first pointer from the queue or wait
GetQueuedCompletionStatus(FIOQueue, A, Cardinal(Data), OL, INFINITE);
//-- Check if we have finalized the queue for completion
if FFinalized or (OL = Pointer($FFFFFFFF)) then begin
Data := nil;
Result := False;
Finalize;
end;
end;
procedure TThreadQueue.Push(Data: Pointer);
begin
if FFinalized then
Raise EThreadStackFinalized.Create('Stack is finalized');
//-- Add/Push a pointer on to the end of the queue
PostQueuedCompletionStatus(FIOQueue, 0, Cardinal(Data), nil);
end;
{ TSimpleThread }
constructor TSimpleThread.Create(CreateSuspended: Boolean;
ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
begin
FreeOnTerminate := AFreeOnTerminate;
FExecuteEvent := ExecuteEvent;
inherited Create(CreateSuspended);
end;
Changed the code as suggested by J... also added critical sections but the problem i am facing now is that when i am trying call multiple task only one thread is being used, Lets say if i added 5 threads in the pool then only one thread is being used which is thread 1. Please check my client code as well in the below section.
procedure TSimpleThread.Execute;
begin
// if Assigned(FExecuteEvent) then
// FExecuteEvent(Self);
while not self.Terminated do begin
try
// FGoEvent.WaitFor(INFINITE);
// FGoEvent.ResetEvent;
EnterCriticalSection(csCriticalSection);
if self.Terminated then break;
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
finally
LeaveCriticalSection(csCriticalSection);
// HandleException;
end;
end;
end;
In the Add method, how can I check if there is any thread which is not busy, if it is not busy then reuse it else create a new thread and add it in ThreadPool list?
{ TThreadPool }
procedure TThreadPool.Add(const Data: Pointer);
begin
FThreadQueue.Push(Data);
// if FThreads.Count < MaxThreadCount then
// begin
// FThreads.Add(TSimpleThread.Create(False, DoHandleThreadExecute, False));
// end;
end;
constructor TThreadPool.Create(HandlePoolEvent: TThreadPoolEvent;
MaxThreads: Integer);
begin
FHandlePoolEvent := HandlePoolEvent;
FThreadQueue := TThreadQueue.Create;
FThreads := TList.Create;
FThreads.Add(TSimpleThread.Create(False, DoHandleThreadExecute, False));
end;
destructor TThreadPool.Destroy;
var
t: Integer;
begin
FThreadQueue.Finalize;
for t := 0 to FThreads.Count-1 do
TThread(FThreads[t]).Terminate;
while (FThreads.Count = 0) do begin
TThread(FThreads[0]).WaitFor;
TThread(FThreads[0]).Free;
FThreads.Delete(0);
end;
FThreadQueue.Free;
FThreads.Free;
inherited;
end;
procedure TThreadPool.DoHandleThreadExecute(Thread: TThread);
var
Data: Pointer;
begin
while FThreadQueue.Pop(Data) and (not TSimpleThread(Thread).Terminated) do begin
try
FHandlePoolEvent(Data, Thread);
except
end;
end;
end;
function TThreadPool.GetMaxThreadCount: Integer;
begin
Result := fis32MaxThreadCount;
end;
procedure TThreadPool.SetMaxThreadCount(const pis32MaxThreadCount: Integer);
begin
fis32MaxThreadCount := pis32MaxThreadCount;
end;
end.
Client Code :
This the client i created to log the data in text file :
unit ThreadClient;
interface
uses Windows, SysUtils, Classes, ThreadUtilities;
type
PLogRequest = ^TLogRequest;
TLogRequest = record
LogText: String;
end;
TThreadFileLog = class(TObject)
private
FFileName: String;
FThreadPool: TThreadPool;
procedure HandleLogRequest(Data: Pointer; AThread: TThread);
public
constructor Create(const FileName: string);
destructor Destroy; override;
procedure Log(const LogText: string);
procedure SetMaxThreadCount(const pis32MaxThreadCnt : Integer);
end;
implementation
(* Simple reuse of a logtofile function for example *)
procedure LogToFile(const FileName, LogString: String);
var
F: TextFile;
begin
AssignFile(F, FileName);
if not FileExists(FileName) then
Rewrite(F)
else
Append(F);
try
Writeln(F, DateTimeToStr(Now) + ': ' + LogString);
finally
CloseFile(F);
end;
end;
constructor TThreadFileLog.Create(const FileName: string);
begin
FFileName := FileName;
//-- Pool of one thread to handle queue of logs
FThreadPool := TThreadPool.Create(HandleLogRequest, 5);
end;
destructor TThreadFileLog.Destroy;
begin
FThreadPool.Free;
inherited;
end;
procedure TThreadFileLog.HandleLogRequest(Data: Pointer; AThread: TThread);
var
Request: PLogRequest;
los32Idx : Integer;
begin
Request := Data;
try
for los32Idx := 0 to 100 do
begin
LogToFile(FFileName, IntToStr( AThread.ThreadID) + Request^.LogText);
end;
finally
Dispose(Request);
end;
end;
procedure TThreadFileLog.Log(const LogText: string);
var
Request: PLogRequest;
begin
New(Request);
Request^.LogText := LogText;
FThreadPool.Add(Request);
end;
procedure TThreadFileLog.SetMaxThreadCount(const pis32MaxThreadCnt: Integer);
begin
FThreadPool.MaxThreadCount := pis32MaxThreadCnt;
end;
end.
This is the form application where i added three buttons, each button click will write some value to the file with thread id and text msg. But the problem is thread id is always same
unit ThreadPool;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ThreadClient;
type
TForm5 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Edit1Change(Sender: TObject);
private
{ Private declarations }
fiFileLog : TThreadFileLog;
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
{$R *.dfm}
procedure TForm5.Button1Click(Sender: TObject);
begin
fiFileLog.Log('Button one click');
end;
procedure TForm5.Button2Click(Sender: TObject);
begin
fiFileLog.Log('Button two click');
end;
procedure TForm5.Button3Click(Sender: TObject);
begin
fiFileLog.Log('Button three click');
end;
procedure TForm5.Edit1Change(Sender: TObject);
begin
fiFileLog.SetMaxThreadCount(StrToInt(Edit1.Text));
end;
procedure TForm5.FormCreate(Sender: TObject);
begin
fiFileLog := TThreadFileLog.Create('C:/test123.txt');
end;
end.
First, and probably most strongly advisable, you might consider using a library like OmniThread to implement a threadpool. The hard work is done for you and you will likely end up making a substandard and buggy product with a roll-your-own solution. Unless you have special requirements this is probably the fastest and easiest solution.
That said, if you want to try to do this...
What you might consider is to just make all of the threads in your pool at startup rather than on-demand. If the server is going to busy at any point then it will eventually end up with a pool of MaxThreadCount soon enough anyway.
In any case, if you want to keep a pool of threads alive and available for work then they would need to follow a slightly different model than what you have written.
Consider:
procedure TSimpleThread.Execute;
begin
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
end;
Here when you run your thread it will execute this callback and then terminate. This doesn't seem to be what you want. What you seem to want is to keep the thread alive but waiting for its next work package. I use a base thread class (for pools) with an execute method that looks something like this (this is somewhat simplified):
procedure TMyCustomThread.Execute;
begin
while not self.Terminated do begin
try
FGoEvent.WaitFor(INFINITE);
FGoEvent.ResetEvent;
if self.Terminated then break;
MainExecute;
except
HandleException;
end;
end;
end;
Here FGoEvent is a TEvent. The implementing class defines what the work package looks like in the abstract MainExecute method, but whatever it is the thread will perform its work and then return to waiting for the FGoEvent to signal that it has new work to do.
In your case, you need to keep track of which threads are waiting and which are working. You will probably want a manager class of some sort to keep track of these thread objects. Assigning something simple like a threadID to each one seems sensible. For each thread, just before launching it, make a record that it is currently busy. At the very end of your work package you can then post a message back to the manager class telling it that the work is done (and that it can flag the thread as available for work).
When you add work to the queue you can first check for available threads to run the work (or create a new one if you wish to follow the model you outlined). If there are threads then launch the task, if there are not then push the work onto the work queue. When worker threads report complete the manager can check the queue for outstanding work. If there is work it can immediately re-deploy the thread. If there isn't work it can flag the thread as available for work (here you might use a second queue for available workers).
A full implementation is too complex to document in a single answer here - this aims just to rough out some general ideas.
With this code I call a form
procedure TfrmMain.actDevTest_2Execute(Sender: TObject);
var
SelectedApp: string;
begin
if ApplicationSelect(Self, SelectedApp) then
ShowMessage(SelectedApp);
end;
The form is looking like the following
unit F_JsApplicationSelect;
interface
uses
{$Include UniDACCommon.inc}
Db, MemDS, DbAccess, Uni,
Classes, Controls, Forms,
U_Forms.Move,
Winapi.Messages, U_CustomMessages,
Dialogs, StdCtrls, Buttons, ComCtrls,
cxGroupBox, cxGraphics, cxControls, cxLookAndFeels,
cxLookAndFeelPainters, cxStyles, dxSkinsCore, dxSkinOffice2010Blue,
dxSkinscxPCPainter, cxCustomData, cxFilter, cxData, cxDataStorage, cxEdit,
cxNavigator, cxDBData, cxCheckBox, cxTextEdit, cxContainer, Vcl.Menus,
cxButtons, cxGridLevel, cxGridCustomTableView, cxGridTableView,
cxGridDBTableView, cxClasses, cxGridCustomView, cxGrid,
dxmdaset;
type
TfrmJsApplicationSelect = class(TForm)
grdApplicationsView1: TcxGridDBTableView;
grdApplicationsLevel1: TcxGridLevel;
grdApplications: TcxGrid;
colContact: TcxGridDBColumn;
colSection: TcxGridDBColumn;
colSelected: TcxGridDBColumn;
cxGroupBox1: TcxGroupBox;
btnOK: TcxButton;
srcApplications: TUniDataSource;
mdApplications: TdxMemData;
mdApplicationsfldselected: TBooleanField;
mdApplicationsfldcontact: TStringField;
mdApplicationsfldsection: TStringField;
mdApplicationsfldposition: TStringField;
mdApplicationsflddate: TDateField;
mdApplicationsfldguid: TStringField;
colPosition: TcxGridDBColumn;
colDdate: TcxGridDBColumn;
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormShow(Sender: TObject);
procedure grdApplicationsView1CellDblClick(Sender: TcxCustomGridTableView;
ACellViewInfo: TcxGridTableDataCellViewInfo; AButton: TMouseButton;
AShift: TShiftState; var AHandled: Boolean);
private
procedure SetupApplications;
procedure MessageClose(var aMessage: TMessage); message WM_FORMCLOSE;
public
constructor Create(aOwner: TComponent; var aApplication: string); reintroduce;
end;
function ApplicationSelect(aOwner: TComponent; var aApplication: string): boolean;
implementation
{$R *.dfm}
uses
System.SysUtils, Winapi.Windows,
F_UniConn,
U_Logfile,
U_AppDb, U_User;
var
lApplication : string;
function ApplicationSelect(aOwner: TComponent; var aApplication: string): boolean;
begin
with TfrmJsApplicationSelect.Create(aOwner, aApplication) do
try
Result := ShowModal = mrOK;
finally
Release;
end;
end;
procedure TfrmJsApplicationSelect.MessageClose(var aMessage: TMessage);
begin
Close;
end;
procedure TfrmJsApplicationSelect.SetupApplications;
var
Query: TUniQuery;
begin
Query := frmUniConn.CreateQuery;
try
Query.SQL.Clear;
Query.SQL.Add('SELECT fldapplication_guid');
Query.SQL.Add(' ,fldapplication_date');
Query.SQL.Add(' ,fldcontact_name');
Query.SQL.Add(' ,fldsection_desc');
Query.SQL.Add(' ,fldposition_desc');
Query.SQL.Add(' ,fldcreated_by');
Query.SQL.Add(' FROM ' + QueryJsApplications);
Query.SQL.Add(' WHERE (fldcreated_by = :fldcreated_by)');
Query.SQL.Add(' ORDER BY fldapplication_date DESC');
Query.ParamByName('fldcreated_by').AsString := User.ID;
try
Query.Execute;
if Query.RecordCount > 0 then
begin
while not Query.Eof do
begin
mdApplications.Open;
mdApplications.Append;
mdApplications.FieldByName('fldselected').AsBoolean := False;
mdApplications.FieldByName('fldguid').AsString := Query.FieldByName('fldapplication_guid').AsString;
mdApplications.FieldByName('flddate').AsDateTime := Query.FieldByName('fldapplication_date').AsDateTime;
mdApplications.FieldByName('fldcontact').AsString := Query.FieldByName('fldcontact_name').AsString;
mdApplications.FieldByName('fldsection').AsString := Query.FieldByName('fldsection_desc').AsString;
mdApplications.FieldByName('fldposition').AsString := Query.FieldByName('fldposition_desc').AsString;
mdApplications.FieldByName('fldguid').AsString := Query.FieldByName('fldapplication_guid').AsString;
mdApplications.Post;
Query.Next;
end;
mdApplications.First;
end;
except
on E:exception do
Logfile.Error('F_JsApplicationSelect.SetupApplications: ' + E.Message);
end;
finally
Query.Free;
end;
end;
constructor TfrmJsApplicationSelect.Create(aOwner: TComponent; var aApplication: string);
begin
inherited Create(aOwner);
lApplication := aApplication;
end;
procedure TfrmJsApplicationSelect.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
mdApplications.First;
while not mdApplications.Eof do
begin
if mdApplications.FieldByName('fldselected').AsBoolean = True then
begin
ShowMessage(mdApplications.FieldByName('fldguid').AsString);
lApplication := mdApplications.FieldByName('fldguid').AsString;
ShowMessage(lApplication);
end;
mdApplications.Next;
end;
except
on E: exception do
Logfile.Error('F_JsApplicationSelect.FormClose: ' + E.Message);
end;
end;
procedure TfrmJsApplicationSelect.FormKeyPress(Sender: TObject; var Key: Char);
begin
If Ord(Key) = 27 Then
ModalResult := mrAbort;
end;
procedure TfrmJsApplicationSelect.FormShow(Sender: TObject);
begin
SetupApplications;
ActiveControl := grdApplications;
if grdApplicationsView1.DataController.RecordCount > 0 then
begin
grdApplicationsView1.Controller.GoToFirst(False);
grdApplicationsView1.Controller.FocusedRecord.MakeVisible;
end;
end;
procedure TfrmJsApplicationSelect.grdApplicationsView1CellDblClick(
Sender: TcxCustomGridTableView; ACellViewInfo: TcxGridTableDataCellViewInfo;
AButton: TMouseButton; AShift: TShiftState; var AHandled: Boolean);
begin
try
mdApplications.Edit;
mdApplications.FieldByName('fldselected').AsBoolean := Not mdApplications.FieldByName('fldselected').AsBoolean;
mdApplications.UpdateRecord;
except
on E: exception do
Logfile.Error('F_JsApplicationSelect.grdApplicationsView1CellDblClick: ' + E.Message);
end;
end;
end.
But why don't I get any value in my SelectedApp variable?
I have another form with identical functions only the var I send to it is a TStringList - that works OK. But the string doesn't work at all.
The code that is needed to understand this is:
function ApplicationSelect(aOwner: TComponent;
var aApplication: string): boolean;
begin
with TfrmJsApplicationSelect.Create(aOwner, aApplication) do
try
Result := ShowModal = mrOK;
finally
Release;
end;
end;
which in turn calls
constructor TfrmJsApplicationSelect.Create(aOwner: TComponent;
var aApplication: string);
begin
inherited Create(aOwner);
lApplication := aApplication;
end;
So, you are asking why the caller of ApplicationSelect does not observe any modification to aApplication when the call to ApplicationSelect returns.
You don't modify the var parameter aApplication in ApplicationSelect. You do pass it as a var parameter to TfrmJsApplicationSelect.Create but again TfrmJsApplicationSelect.Create does not modify it. Since a string variable is a value, the caller sees no modification to the variable, because it was not modified.
My other comment about ApplicationSelect is that you should call Free rather than Release.
Beyond that I could make many more comments about your code, but I will refrain from attempting a comprehensive code review and comment solely on the direct question that you asked.
In the comments you ask why changing aApplication to TStringList allows the caller to observe modifications. That's because Delphi class variables are references to the object. When you pass a TStringList variable as a parameter, you are passing a reference to the object. When you call methods on that object, any mutations are performed on the actual object.
So, how would I change this code to allow a string value to be returned? First of all I would make ApplicationSelect be a function that returns a string. In case of cancellation I would Abort.
function SelectApplication(aOwner: TComponent): string;
var
Form: TfrmJsApplicationSelect;
begin
Form := TfrmJsApplicationSelect.Create(aOwner);
try
if Form.ShowModal <> mrOK then
Abort;
Result := Form.Application;
finally
Free;
end;
end;
I would absolutely remove the global variable lApplication. You should avoid using global variables if at all possible. I'd remove every single one from the code here.
Instead add a private field to the form to hold the information:
FApplication: string;
And expose it as a public property:
property Application: string read FApplication;
Then the form merely needs to set FApplication and the caller can see that value.
I use threads in my project. And I wanna kill and terminate a thread immediately.
sample:
type
test = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
end;
var
Form1: TForm1;
a:tthread;
implementation
{$R *.dfm}
procedure test.Execute;
begin
Synchronize(procedure begin
form1.ProgressBar1.position := 0;
sleep(5000);
form1.ProgressBar1.position := 100;
end
);
end;
procedure TForm1.btn_startClick(Sender: TObject);
begin
a:=test.Create(false);
end;
procedure TForm1.btn_stopClick(Sender: TObject);
begin
terminatethread(a.ThreadID,1); //Force Terminate
end;
But when I click on the btn_stop (after clicking on btn_start), the thread won't stop. So how can stop this thread immediately?
BTW a.terminate; didn't work too.
Thanks.
This is a complete misuse of a worker thread. You are delegating all of the thread's work to the main thread, rendering the worker thread useless. You could have used a simple timer instead.
The correct use of a worker thread would look more like this instead:
type
test = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
end;
var
Form1: TForm1;
a: test = nil;
implementation
{$R *.dfm}
procedure test.Execute;
var
I: integer
begin
Synchronize(
procedure begin
form1.ProgressBar1.Position := 0;
end
);
for I := 1 to 5 do
begin
if Terminated then Exit;
Sleep(1000);
if Terminated then Exit;
Synchronize(
procedure begin
Form1.ProgressBar1.Position := I * 20;
end
);
end;
Synchronize(
procedure begin
form1.ProgressBar1.Position := 100;
end
);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
btn_stopClick(nil);
end;
procedure TForm1.btn_startClick(Sender: TObject);
begin
if a = nil then
a := test.Create(False);
end;
procedure TForm1.btn_stopClick(Sender: TObject);
begin
if a = nil then Exit;
a.Terminate;
a.WaitFor;
FreeAndNil(a);
end;
The problem is the thread waits by using Sleep. This method will keep the thread sleeping for the specified time, no matter what happens around it. In order to be able to "break sleep" you should use an event. The code should be changed to this:
procedure test.Execute;
begin
Synchronize(procedure begin
form1.ProgressBar1.position := 0;
end);
Event.WaitFor(5000);
if not IsTerminated then
Synchronize(procedure begin
form1.ProgressBar1.position := 100;
end);
end;
The event should be created and destroyed like this:
constructor test.Create(aCreateSuspended: Boolean);
begin
inherited;
Event := TSimpleEvent.Create;
end;
destructor test.Destroy;
begin
FreeAndNil(Event);
inherited;
end;
In order to stop the thread, the code is:
procedure TForm1.btn_stopClick(Sender: TObject);
begin
a.Terminate;
end;
But simply calling Terminate won´t signal the Event, so we have to reimplement Terminate:
procedure test.Terminate;
begin
inherited;
Event.SetEvent;
end;
Calling SetEvent will signal the event, so it will wake the thread up. The execution continues in the next line, that tests for thread termination and decides to execute the second part of the code or not.