TFloatAnimation within anonymous thread. Thread wont die and animation wont restart - multithreading

I've been struggling with this for a day or two and cannot find an answer anywhere. I thought this answer might help but it didn't.
In my sample code below I have two Timage Components each containing a "Start Image". When clicking on the "Start Button" two anonymous threads are created, one animates Image1 between the Start Image and End Image, the other does the same for Image2.
My problem is that when the KillAnimation boolean is set to True both animations should stop (which they do) but only one of the threads exit, the other one stops animating but leaves the image mid-animation.
I have the same problem if I use a predefined thread as well.
The sample application has only two images, the real world app can have anywhere from 15 to 24. Anonymous threads seem to suit because I can create them and no have to worry about defining up to 24 TThreads. I hope that makes sense.
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes,
System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Objects,
FMX.Controls.Presentation, FMX.StdCtrls, FMX.Ani, FMX.Effects,
FMX.Filter.Effects;
type
TForm1 = class(TForm)
Image1: TImage;
Image2: TImage;
BtnStop: TButton;
BtnStart: TButton;
BtnReset: TButton;
procedure BtnStopClick(Sender: TObject);
procedure BtnStartClick(Sender: TObject);
procedure BtnResetClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure createthread(TheImage: TImage; TargetBMP: String);
end;
var
Form1: TForm1;
KillAnimation: Boolean;
implementation
{$R *.fmx}
procedure TForm1.BtnStopClick(Sender: TObject);
begin
KillAnimation := true;
end;
procedure TForm1.createthread(TheImage: TImage; TargetBMP: String);
begin
{ The thread works right up until it is stopped. Even though two
threads are started only one finishes. In addition, the images
do not end up as the target image, and neither image can be
reset even if I reload them from files. }
TThread.CreateAnonymousThread(
procedure()
var
Wiggle: TWiggleTransitionEffect;
TheFloat: TFloatAnimation;
begin
TThread.NameThreadForDebugging('Animate ' + TheImage.Name);
Wiggle := TWiggleTransitionEffect.Create(Nil);
Wiggle.RandomSeed := 0.3;
Wiggle.Progress := 0;
Wiggle.Parent := TheImage;
TThread.Synchronize(TThread.CurrentThread,
procedure()
Begin
Wiggle.Target.LoadFromFile(TargetBMP)
end);
TheFloat := TFloatAnimation.Create(Nil);
TheFloat.Parent := Wiggle;
TheFloat.PropertyName := 'Progress';
TheFloat.Duration := 2;
TheFloat.AutoReverse := true;
TheFloat.Loop := true;
TheFloat.StartValue := 0;
TheFloat.StopValue := 100;
TheFloat.StartFromCurrent := false;
TheFloat.start;
while not KillAnimation do
application.handlemessage;
TheFloat.stop;
end).start;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Image1.Bitmap.LoadFromFile('c:\sample\startimage.png');
Image2.Bitmap.LoadFromFile('c:\sample\startimage.png');
end;
procedure TForm1.BtnStartClick(Sender: TObject);
begin
KillAnimation := false;
createthread(Image1, 'c:\sample\endimage.png');
createthread(Image2, 'c:\sample\endimage.png');
end;
procedure TForm1.BtnResetClick(Sender: TObject);
begin
KillAnimation := false;
Image1.Bitmap.LoadFromFile('c:\sample\startimage.png');
Image2.Bitmap.LoadFromFile('c:\sample\startimage.png');
end;
end.
I would have thought that creating the Transition and FloatAnimation within the thread meant they would be destroyed when done because FreeOnTerminate is True.
When I try to reset the Images using "image1.bitmap.loadfromfile" it doesn't change.
The images are 170 x 170 png files.
What have I done wrong here?
My goal is to pass TImage and an Image File to the thread, let it animate until told to stop. It is unlikely that I'll need all 24 images to animate, but you never know.
Apologies if I shouldn't have posted all the code from my sample. At least you can see everything going on.

You should NOT be using a thread for this at all. UI elements, including visual effects, should be used only in the main UI thread. And unless you are developing your app for mobile platforms, objects are not destroyed automatically when they go out of scope, you have to destroy them yourself when you are done using them, or else assign them an Owner that will destroy them for you.
Try this instead:
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Objects, FMX.Controls.Presentation,
FMX.StdCtrls, FMX.Ani, FMX.Effects, FMX.Filter.Effects;
type
TForm1 = class(TForm)
Image1: TImage;
Image2: TImage;
BtnStop: TButton;
BtnStart: TButton;
BtnReset: TButton;
procedure BtnStopClick(Sender: TObject);
procedure BtnStartClick(Sender: TObject);
procedure BtnResetClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
Float1: TFloatAnimation;
Float2: TFloatAnimation;
function PrepareEffect(TheImage: TImage; const TargetBMP: String): TFloatAnimation;
procedure ResetImages;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
procedure TForm1.BtnResetClick(Sender: TObject);
begin
ResetImages;
end;
procedure TForm1.BtnStartClick(Sender: TObject);
begin
Float1.start;
Float2.start;
end;
procedure TForm1.BtnStopClick(Sender: TObject);
begin
Float1.stop;
Float2.stop;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ResetImages;
Float1 := PrepareEffect(Image1, 'c:\sample\endimage.png');
Float2 := PrepareEffect(Image2, 'c:\sample\endimage.png');
end;
function TForm1.PrepareEffect(TheImage: TImage; const TargetBMP: String): TFloatAnimation;
var
Wiggle: TWiggleTransitionEffect;
TheFloat: TFloatAnimation;
begin
Wiggle := TWiggleTransitionEffect.Create(Self);
Wiggle.RandomSeed := 0.3;
Wiggle.Progress := 0;
Wiggle.Parent := TheImage;
Wiggle.Target.LoadFromFile(TargetBMP);
TheFloat := TFloatAnimation.Create(Self);
TheFloat.Parent := Wiggle;
TheFloat.PropertyName := 'Progress';
TheFloat.Duration := 2;
TheFloat.AutoReverse := true;
TheFloat.Loop := true;
TheFloat.StartValue := 0;
TheFloat.StopValue := 100;
TheFloat.StartFromCurrent := false;
Result := TheFloat;
end;
procedure TForm1.ResetImages;
begin
Image1.Bitmap.LoadFromFile('c:\sample\startimage.png');
Image2.Bitmap.LoadFromFile('c:\sample\startimage.png');
end;
end.

Related

Delphi. How to Send a Thread a Message from a Form and for the Thread to Process the Message

I have a Main Form that creates a Thread.
The Thread creates a Form with a Progress bar.
What I'm trying to do is create the Thread from the Main Form and send a message to the Thread to increase the Progress bar on the Thread Form.
This will allow me to execute code and provide the user with the progress.
So far I have the Main Form:-
unit uMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, contnrs,
StdCtrls, uThread, ExtCtrls;
type
TMainForm = class(TForm)
btnCreateForm: TButton;
btnSendMessage: TButton;
procedure btnCreateFormClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnSendMessageClick(Sender: TObject);
private
{ Private declarations }
MyProgressBarThread: TProgressBarThread;
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.btnCreateFormClick(Sender: TObject);
begin
MyProgressBarThread := TProgressBarThread.Create(Self);
end;
procedure TMainForm.btnSendMessageClick(Sender: TObject);
begin
// Is this correct way to send a message to the Thread?
PostThreadMessage(MyProgressBarThread.Handle, WM_USER, 0, 0);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
if Assigned(MyProgressBarThread) then
MyProgressBarThread.Terminate;
end;
end.
And the Thread:-
unit uThread;
interface
uses
Forms, StdCtrls, Graphics, ExtCtrls, ClipBrd, Contnrs, JPeg, SysUtils,
ComCtrls, System.Classes{taRightJustify}, Winapi.Messages, Winapi.Windows;
type
TProgressBarThread = class(TThread)
private
{ Private declarations }
FForm: TForm;
FUse_Progress_Position_Label: Boolean;
lbProcessing_Name: TLabel;
lbProcessing_Description: TLabel;
lbProcessing_Position_Number: TLabel;
ProgressBar1: TProgressBar;
procedure OnCloseForm(Sender: TObject; var Action: TCloseAction);
procedure OnDestroyForm(Sender: TObject);
protected
procedure Execute; override;
public
constructor Create(AForm: TForm);
end;
implementation
{ TProgressBarThread }
constructor TProgressBarThread.Create(AForm: TForm);
begin
FForm := TForm.Create(nil);
lbProcessing_Name := TLabel.Create(FForm);
ProgressBar1 := TProgressBar.Create(FForm);
lbProcessing_Description := TLabel.Create(FForm);
lbProcessing_Position_Number := TLabel.Create(FForm);
with FForm do
begin
Caption := 'Please Wait...';
Left := 277;
Top := 296;
BorderIcons := [biSystemMenu];
BorderStyle := bsSingle;
ClientHeight := 80;
ClientWidth := 476;
Color := clBtnFace;
Font.Color := clWindowText;
Font.Height := -11;
Font.Name := 'MS Sans Serif';
Font.Style := [];
FormStyle := fsStayOnTop;
OldCreateOrder := False;
Position := poMainFormCenter;
PixelsPerInch := 96;
OnClose := OnCloseForm;
OnDestroy := OnDestroyForm;
with lbProcessing_Name do
begin
Parent := FForm;
Left := 16;
Top := 24;
Width := 130;
Height := 13;
Caption := 'Processing Request... ';
Font.Color := clWindowText;
Font.Height := -11;
Font.Name := 'MS Sans Serif';
Font.Style := [fsBold];
ParentFont := False;
end;
with lbProcessing_Description do
begin
Parent := FForm;
Left := 160;
Top := 24;
Width := 3;
Height := 13;
Font.Color := clBlue;
Font.Height := -11;
Font.Name := 'MS Sans Serif';
Font.Style := [];
ParentFont := False;
end;
with lbProcessing_Position_Number do
begin
Parent := FForm;
Left := 456;
Top := 24;
Width := 6;
Height := 13;
Alignment := taRightJustify;
Caption := '0';
Visible := False;
Font.Color := clBlue;
Font.Height := -11;
Font.Name := 'MS Sans Serif';
Font.Style := [];
end;
with ProgressBar1 do
begin
Parent := FForm;
Left := 16;
Top := 48;
Width := 449;
Height := 17;
TabOrder := 0;
end;
end;
FForm.Show;
inherited Create(False);
end;
procedure TProgressBarThread.Execute;
var
Msg: TMsg;
begin
FreeOnTerminate := True;
// Is this the correct way to Look for Messages sent to the Thread and to handle them?
while not (Terminated or Application.Terminated) do
begin
if PeekMessage(&Msg, 0, 0, 0, PM_NOREMOVE) then
begin
if Msg.message > 0 then
ProgressBar1.Position := ProgressBar1.Position + 1;
end;
end;
end;
procedure TProgressBarThread.OnCloseForm(Sender: TObject; var Action: TCloseAction);
begin
Terminate;
// WaitFor;
end;
procedure TProgressBarThread.OnDestroyForm(Sender: TObject);
begin
if not Terminated then
begin
Terminate;
WaitFor;
end;
end;
end.
Is this the correct way to go for my situation? If not then any examples?
Is the PostThreadMessage(MyProgressBarThread.Handle, WM_USER, 0, 0); correct?
How do I Listening for messages in the Thread and process them?
tia
Updated based on comments 09/07/2021
Is this code correct and safe:-
MainForm
unit uMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, contnrs,
StdCtrls, uThread, ExtCtrls;
type
TMainForm = class(TForm)
btnStart_Process: TButton;
procedure btnStart_ProcessClick(Sender: TObject);
private
{ Private declarations }
Start_ProcessThread: TStart_ProcessThread;
procedure TheCallback(const ProgressBarPosition: Integer);
public
{ Public declarations }
end;
var
MainForm: TMainForm;
hLogWnd: HWND = 0;
implementation
uses
uProgressBar;
{$R *.DFM}
procedure TMainForm.btnStart_ProcessClick(Sender: TObject);
begin
frmProgressBar.ProgressBar1.Max := Con_Max_ProgressBarPosition;
frmProgressBar.ProgressBar1.Position := 0;
frmProgressBar.Show;
Start_ProcessThread := TStart_ProcessThread.Create(TheCallback);
end;
procedure TMainForm.TheCallback(const ProgressBarPosition: Integer);
begin
if ProgressBarPosition <> Con_Finished_Processing then
frmProgressBar.ProgressBar1.Position := ProgressBarPosition
else
frmProgressBar.Close;
end;
end.
ProgressBarForm
unit uProgressBar;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls;
type
TfrmProgressBar = class(TForm)
ProgressBar1: TProgressBar;
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmProgressBar: TfrmProgressBar;
implementation
{$R *.dfm}
end.
Thread
unit uThread;
interface
uses
Forms, StdCtrls, Graphics, ExtCtrls, ClipBrd, Contnrs, JPeg, SysUtils,
ComCtrls, System.Classes{taRightJustify}, Winapi.Messages, Winapi.Windows;
const
Con_Finished_Processing = -1;
Con_Max_ProgressBarPosition = 1024 * 65536;
type
TMyCallback = procedure(const ProgressBarPosition: Integer) of object;
TStart_ProcessThread = class(TThread)
private
FCallback : TMyCallback;
procedure Execute; override;
procedure SendLog(I: Integer);
public
constructor Create(aCallback : TMyCallback);
end;
implementation
{ TStart_ProcessThread }
constructor TStart_ProcessThread.Create(aCallback: TMyCallback);
begin
inherited Create(false);
FCallback := aCallback;
end;
procedure TStart_ProcessThread.SendLog(I: Integer);
begin
if not Assigned(FCallback) then
Exit;
Self.Queue( // Executed later in the main thread
procedure
begin
FCallback(I{ThePosition});
end
);
end;
procedure TStart_ProcessThread.Execute;
var
I: Integer;
begin
// Do the Work Load here:-
for I := 0 to Con_Max_ProgressBarPosition do
begin
if ((I mod 65536) = 0) then
begin
// Send back the progress of the work here:-
SendLog(I);
Sleep(10);
end;
end;
// Finished
SendLog(Con_Finished_Processing);
end;
end.
If your going for additional Components: i would suggest looking at Omni Thread Library.
http://www.omnithreadlibrary.com/book/chap10.html#leanpub-auto-sending-data-from-a-worker-to-a-form
The 7.13.2 Example in the current Version (Sending data from a worker to a form)
Its a great Library and the free book from the link above is a good source for many multithreaded Scenarios.
I use almost every Time the 3.2 Blocking collection (in the text there is a link to the demo source) Its not specially what your looking for, but a combination of both should be powerfull to create multihreaded chains of workloads.
kbmMW contains a feature called SmartEvent which I would recommend checking out. It works great in such scenarios, where you want different parts of your code (threaded or not) to communicate with each other and transfer data.
It works as simple as this:
TForm1 = class(...)
...
private
procedure FormCreate(Sender: TObject);
public
[kbmMW_Event('UPDATESTATUS',[mweoSync])]
procedure UpdateStatus(const APct:integer);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Event.Subscribe(self);
end;
procedure TForm1.UpdateStatus(const APct:integer);
begin
Label1.Caption:='Pct='+inttostr(APct);
end;
and then in your thread do:
procedure TYourThread.Execute;
begin
...
Event.Notify('UPDATESTATUS',pct);
...
end;
All thread synchronization etc. will be handled automatically for you.
You can even make calls, expecting data back, and there can be any number of subscribers for your notifications.
kbmMW is a toolbox that fully supports Delphi and all platforms.
You can read more about SmartEvent here: https://components4developers.blog/2019/11/11/smartevent-with-kbmmw-1/

TThread checksynchronize issue with dll

i have this TThread that i use inside my dll to update some visual control its working fine but i face issue when i try to close my dll and reopen it again its raised this exception
checksynchronize called from thread which is not the main thread
what iam doing wrong ? i need to call checksynchronize within timer because i will update some vcl with Threading while app running .
Here is my Thread unit
unit Thread;
interface
uses Messages, Windows, SysUtils, dialogs, Classes, Menus, forms, ComOBJ,
ShlObj;
{ Thread client }
type
TThreadCallbackProc = procedure(Sender: TObject; Updatestring : string) of object;
TAPPTHREAD = class(TThread)
private
Fstatus : String;
FOnCallbackProc: TThreadCallbackProc;
procedure dosomework;
procedure DoCallbackProc;
//
protected
procedure Execute; override;
Public
constructor Create(CreateSuspended: Boolean; aThreadCallbackProc: TThreadCallbackProc);
destructor Destroy; override;
end;
var
APPTHREAD : TAPPTHREAD;
implementation
constructor TAPPTHREAD.Create(CreateSuspended: Boolean;
aThreadCallbackProc: TThreadCallbackProc);
begin
inherited Create(CreateSuspended);
FreeOnTerminate := True;
FOnCallbackProc := aThreadCallbackProc;
end;
destructor TAPPTHREAD.Destroy;
begin
//
end;
procedure TAPPTHREAD.DoCallbackProc;
begin
if Assigned(FOnCallbackProc) then
FOnCallbackProc(self, Fstatus);
end;
procedure TAPPTHREAD.Execute;
begin
while not Terminated do
begin
Fstatus := 'Synched';
if Fstatus <> '' then
dosomework;
end;
end;
procedure TAPPTHREAD.dosomework;
begin
if Assigned(FOnCallbackProc) then
begin
Synchronize(DoCallbackProc);
end;
end;
end.
Main Form
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Timer1: TTimer;
Timer2: TTimer;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
procedure callbackproc(Sender: TObject; Updatestring : String);
end;
var
Form1: TForm1;
implementation
uses Thread;
{$R *.dfm}
procedure TForm1.callbackproc(Sender: TObject; Updatestring: String);
begin
label1.Caption := updatestring;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := Cafree;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
try
if Assigned(APPTHREAD) then
AppThread.Terminate;
except end;
try
Timer2.Enabled := False;
except end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
Timer2.Enabled := True;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
Checksynchronize;
end;
end.
DFM
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 242
ClientWidth = 472
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnClose = FormClose
OnDestroy = FormDestroy
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 0
Top = 0
Width = 472
Height = 13
Align = alTop
Caption = 'Label1'
ExplicitLeft = 232
ExplicitTop = 136
ExplicitWidth = 31
end
object Timer1: TTimer
Enabled = False
OnTimer = Timer1Timer
Left = 232
Top = 128
end
object Timer2: TTimer
Enabled = False
Interval = 1
OnTimer = Timer2Timer
Left = 320
Top = 168
end
end
dll code
library dllapp;
uses
System.SysUtils,
Themes,
Windows,
Forms,
dialogs,
Graphics,
Vcl.ExtCtrls,
Unit1 in 'Unit1.pas' {Unit1},
DThreadsend in 'Thread.pas';
var
mHandle: THandle;
DLLHandle: Longint = 0;
function createApp(Width: Integer; Height: Integer; hw: HWnd;
app: TApplication): boolean; stdcall;
begin
mHandle := CreateMutex(nil, True, 'APPNAMETLOAD');
if GetLastError = ERROR_ALREADY_EXISTS then
begin
Halt;
end;
try
form1 := Tform1.CreateParented(hw); // **
form1.Width := Width;
form1.Height := Height;
Result := True
except
on e: exception do
begin
Result := False;
end;
end;
end;
procedure closeApp; stdcall;
begin
ApplicationClosed := True;
try
if mHandle <> 0 then
CloseHandle(mHandle);
except
end;
if Assigned(form1) then
try
FreeAndNil(form1);
except
end;
try
OptimizeRamUsage;
except
end;
end;
procedure showapp; stdcall;
begin
try
form1.Visible := True;
except
end;
form1.Show;
end;
procedure DLLEntryProc(EntryCode: Integer);
begin
case EntryCode of
DLL_PROCESS_DETACH:
begin
StyleServices.Free;
end;
DLL_PROCESS_ATTACH:
begin
end;
DLL_THREAD_ATTACH:
begin
end;
DLL_THREAD_DETACH:
begin
end;
end;
end;
exports
closeApp,
createApp,
showapp;
begin
DllProc := #DLLEntryProc;
end.
Host Application and how i create Dll
loadapp Unit
unit loadapp;
interface
uses windows, forms, System.SysUtils , dialogs;
procedure loadmainapp;
type
TcreaFunc = function (Width: Integer; Height: Integer; hw:HWnd; app: TApplication): boolean; stdcall;
TshowFunc = procedure stdcall;
TCloseAppFunc = procedure stdcall;
var
dllHandle : THandle = 0;
creaFunc : TcreaFunc;
showFunc : TshowFunc;
CloseAppFunc: TCloseAppFunc;
implementation
uses Mainapp;
procedure loadmainapp;
var
S: widestring;
PW: PWideChar;
begin
S := 'dllapp.dll';
pw:=pwidechar(widestring(s));
dllHandle := LoadLibrary(pw);
if dllHandle <> 0 then
begin
#creaFunc := GetProcAddress(dllHandle, 'createApp');
#showFunc := GetProcAddress(dllHandle, 'showapp');
if Assigned (creaFunc) then
begin
creaFunc(mainfrm.panel1.Width, mainfrm.panel1.Height, mainfrm.panel1.Handle, Application);
DisFunc;
end
else
ShowMessage('ERROR');
end
else
begin
ShowMessage('ERROR');
end;
end;
end.
Active Form
unit activeform;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActiveX, AxCtrls, Frmldr_TLB, StdVcl, Vcl.ExtCtrls, ShlObj, Vcl.StdCtrls, SHDocVw, MSHTML;
type
TActiveFrmldr = class(TActiveForm, IActiveFrmldr)
mpanl: TPanel;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
end;
implementation
uses ComObj, ComServ, Mainapp, libacload;
{$R *.DFM}
{ TActiveFrmldr }
procedure TActiveFrmldr.FormDestroy(Sender: TObject);
begin
if dllHandle <> 0 then
begin
#CloseAppFunc := GetProcAddress(dllHandle, 'closeApp');
CloseAppFunc;
FreeLibrary(dllHandle); //release dll
end;
if Assigned(mainfrm) then
try
FreeAndNil(mainfrm);
except
end;
end;
procedure TActiveFrmldr.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
mainfrm.Parent := mpanl;
mainfrm.Left := 0;
mainfrm.Top := 0;
mainfrm.Width := self.Width;
mainfrm.Height := self.Height;
mainfrm.Align := alClient;
mainfrm.Show;
end;
procedure TActiveFrmldr.FormCreate(Sender: TObject);
begin
Application.CreateForm(Tmainfrm, mainfrm);
Timer1.Enabled := True;
end;
initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
TActiveFrmldr,
Class_ActiveFrmldr,
0,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
finalization
end.
Main app Form that call load library function
unit Mainapp;
interface
uses
Windows, Messages, System.SysUtils, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, System.Classes, libacload,
Vcl.Controls, Vcl.StdCtrls;
type
Tmainfrm = class(TForm)
Panel1: TPanel;
Timer1: TTimer;
Timer2: TTimer;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
mainfrm: Tmainfrm;
implementation
Uses loadapp;
{$R *.dfm}
procedure Tmainfrm.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;
procedure Tmainfrm.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
loadmainapp;
end;
procedure Tmainfrm.Timer2Timer(Sender: TObject);
begin
checksynchronize; // i do this to check some thread in activex it self
end;
end.
The error means that CheckSynchronize() is being called in a thread whose ThreadID does not match the RTL's global System.MainThreadID variable.
A DLL does not have a main thread of its own. MainThreadID gets initialized to whatever thread is initializing the DLL. So, if your DLL is creating its GUI in a different thread than the one that is initializing your DLL, CheckSynchronize() (and TThread.Synchronize(), and TThread.Queue()) will not work unless you manually update the MainThreadID variable to the ThreadID that is running your GUI. Do that before creating your worker thread, eg:
if IsLibrary then
MainThreadID := GetCurrentThreadID;
Form1 := TForm1.Create(nil);
Or:
procedure TForm1.FormCreate(Sender: TObject);
begin
if IsLibrary then
MainThreadID := GetCurrentThreadID;
end;
Or:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
if IsLibrary then
MainThreadID := GetCurrentThreadID;
APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
Timer2.Enabled := True;
end;

How can I terminate thread directly outside of thread in delphi?

I want to terminate thread by clicking the button. If the thread normally works without user interruption it is OK but sometimes user needs to abort thread and that's the question that how user abort the thread.
Here is my code that I tested:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, mmsystem, ExtCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
procedure Image1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
end;
type
hangth = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
procedure play;
end;
var
Form1: TForm1;
played: boolean;
szalhang: hangth;
implementation
{$R *.dfm}
procedure hangth.play;
begin
played := true;
szalhang.Terminate;
end;
procedure hangth.Execute;
begin
played := false;
SndPlaySound(pchar('hang.wav'), SND_SYNC);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
played := true;
end;
procedure TForm1.Image1Click(Sender: TObject);
begin
if played = true then begin
szalhang := hangth.Create(true);
szalhang.Resume;
end else begin
szalhang.Terminate();
// here i want to terminate thread, but it doesn't want to be killed.
end;
end;
end.
When you call TThread.Terminate(), it sets the TThread.Terminated property to true and does nothing else. It is the responsibility of your TThread.Execute() code to look at the TThread.Terminated property periodically and exit gracefully when it is True. However, in this situation, that is not possible because SndPlaySound() is blocking the thread, and there is no way to interrupt SndPlaySound() when it is running in SND_SYNC mode. Your only option would be to use the Win32 API TerminateThread() function to perform a brute-force termination of the thread.
Since you obviously need more control over the playback of the audio, and detection of when the audio is finished playing, then SndPlaySound() is not the best solution for your needs. You have a TForm, you might consider using Delphi's TMediaPlayer component, for example:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.MPlayer;
type
MPlayerState = (mpsClosed, mpsOpened, mpsPlaying);
TForm1 = class(TForm)
Image1: TImage;
MediaPlayer1: TMediaPlayer;
procedure MediaPlayer1Notify(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Image1Click(Sender: TObject);
private
{ Private declarations }
State: MPlayerState;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm56.FormCreate(Sender: TObject);
begin
State := mpsClosed;
MediaPlayer1.FileName := 'C:\full path to\hang.wav';
end;
procedure TForm56.MediaPlayer1Notify(Sender: TObject);
begin
case MediaPlayer1.Mode of
mpStopped, mpPlaying:
State := mpsOpened;
end;
end;
procedure TForm1.Image1Click(Sender: TObject);
begin
if State = mpsClosed then
begin
MediaPlayer1.Notify := False;
MediaPlayer1.Wait := True;
MediaPlayer1.Open;
State := mpsOpened;
end;
if State = mpsOpened then
begin
MediaPlayer1.Notify := True;
MediaPlayer1.Wait := False;
MediaPlayer1.Play;
if MediaPlayer1.Error = 0 then
State := mpsPlaying
end else
begin
MediaPlayer1.Notify := False;
MediaPlayer1.Wait := True;
MediaPlayer1.Stop;
State := mpsOpened;
MediaPlayer1.Notify := False;
MediaPlayer1.Wait := True;
MediaPlayer1.Close;
State := mpsClosed;
end;
end;
end.

Why thread code is not executed?

I have 4 threads created at runtime. Each thread enters critical section, changes global variable, exits critical section and shows message dialog with the result. OnThreadTerminate I also have a message dialog. It seems to be random, but still, I sometimes get 3 messages with the result and one saying that thread is terminated. How is it even possible? Win7 x64.
There is my full code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, Vcl.ComCtrls,
IdThreadComponent, idHTTP, SyncObjs;
const
THREAD_NAME = 'MyidThreadComponent';
type
TForm1 = class(TForm)
StatusBar1: TStatusBar;
BitBtn1: TBitBtn;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
FCriticalSection: TCriticalSection;
FGlobalVariable: integer;
procedure CreateThreads(const ACount: integer; const AStart: boolean);
function GetWebsiteContent(const AURL: string): string;
procedure MyIdThreadComponentOnRunHandler(Sender: TIdThreadComponent);
procedure MyIdThreadComponentOnTerminateHandler(Sender: TIdThreadComponent);
public
{ Public declarations }
property GlobalVariable: integer read FGlobalVariable write FGlobalVariable;
property CriticalSection: TCriticalSection read FCriticalSection;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FCriticalSection := TCriticalSection.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeAndNil(FCriticalSection);
end;
function TForm1.GetWebsiteContent(const AURL: string): string;
var
_MyidHTTP: TidHTTP;
begin
_MyidHTTP := TidHTTP.Create(self);
try
Result := _MyidHTTP.Get(AURL);
finally
FreeAndNil(_MyidHTTP);
end;
end;
procedure TForm1.MyIdThreadComponentOnRunHandler(Sender: TIdThreadComponent);
var
_LocalVariable: integer;
begin
CriticalSection.Acquire;
try
// Safe way to deal with global variables. Only one thread will enter
// CriticalSection at time.
_LocalVariable := GlobalVariable;
_LocalVariable := _LocalVariable * 2;
GlobalVariable := _LocalVariable;
finally
CriticalSection.Release;
end;
ShowMessage(Sender.Name + ' started: ' + IntToStr(_LocalVariable));
Sender.Terminate;
end;
procedure TForm1.MyIdThreadComponentOnTerminateHandler
(Sender: TIdThreadComponent);
begin
ShowMessage(Sender.Name + ' terminated.');
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
GlobalVariable := 1;
CreateThreads(4 { System.CPUCount + 1 } , true);
end;
procedure TForm1.CreateThreads(const ACount: integer; const AStart: boolean);
var
_MyIdThreadComponent: TIdThreadComponent;
i: integer;
begin
if ACount > 0 then
for i := 1 to ACount do
begin
_MyIdThreadComponent := FindComponent(THREAD_NAME + IntToStr(i))
as TIdThreadComponent;
if not Assigned(_MyIdThreadComponent) then
begin
_MyIdThreadComponent := TIdThreadComponent.Create(self);
_MyIdThreadComponent.Name := THREAD_NAME + IntToStr(i);
_MyIdThreadComponent.Tag := i;
_MyIdThreadComponent.OnRun := MyIdThreadComponentOnRunHandler;
_MyIdThreadComponent.OnTerminate :=
MyIdThreadComponentOnTerminateHandler;
{$IFDEF MSWINDOWS}
_MyIdThreadComponent.Priority := tpNormal;
{$ENDIF}
{$IFDEF MACOS}
_MyIdThreadComponent.Priority := 1;
{$ENDIF}
end;
if AStart = true then
if Assigned(_MyIdThreadComponent) then
_MyIdThreadComponent.Start;
end;
end;
end.
Showmessage is not the best way to show the output as its not thread safe. Instead, if you use a memo or other control and wrap it in a synchronize call it will be easier to see the results. I modified your routine to output to a memo, and included the ThreadId before and inside the synchronize call so you can better understand what is happening.
Keep in mind that your threads will not always output in the order you may think they will, it is entirely possible that thread 4 will output before thread 1, even though thread 1 was started first and 4 last.
procedure TForm13.MyIdThreadComponentOnRunHandler(Sender: TIdThreadComponent);
var
_LocalVariable: integer;
_LocalThreadId : Cardinal;
begin
fCriticalSection.Acquire;
try
// Safe way to deal with global variables. Only one thread will enter
// CriticalSection at time.
_LocalVariable := GlobalVariable;
_LocalVariable := _LocalVariable * 2;
GlobalVariable := _LocalVariable;
finally
fCriticalSection.Release;
end;
_LocalThreadId := TThread.CurrentThread.ThreadID;
TThread.Synchronize(TThread.CurrentThread,procedure begin
memo1.Lines.Add(Format('%s Started (%d/%d): %d',[Sender.Name,_LocalThreadId,TThread.CurrentThread.ThreadID,_LocalVariable]));
end);
Sender.Terminate;
end;
procedure TForm13.MyIdThreadComponentOnTerminateHandler
(Sender: TIdThreadComponent);
begin
// note sync call is not needed as this is executed in the context of the main thread.
memo1.Lines.Add(Format('%s terminated. (%d)',[Sender.Name,TThread.CurrentThread.ThreadID]));
end;

Delphi - Updating status bar from thread

What is the best way to update a status bar in mainform from one tthread class object.
For Example, I have one TThread object that make a very big quanty of stuff and i want that the verbose message acording to what soft do you do appear on status bar.
Create the thread with a reference to a callback method, which can be called synchonized if assigned.
Example;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TInfoMessageCall=Procedure (const info:String) of object;
TMyThread=Class(TThread)
Constructor Create(Susp:Boolean;CallBack:TInfoMessageCall);overload;
Procedure Execute;override;
private
FMessage:String;
FInfoProc:TInfoMessageCall;
Procedure CallCallBack;
End;
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure ACallBack(const s: String);
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TMyThread }
Procedure TForm1.ACallBack(Const s:String);
begin
Caption := s;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
With TMyThread.Create(false,ACallBack) do
FreeOnTerminate := true;
end;
procedure TMyThread.CallCallBack;
begin
if Assigned(FInfoProc) then FInfoProc(FMessage);
end;
constructor TMyThread.Create(Susp: Boolean; CallBack: TInfoMessageCall);
begin
Inherited Create(Susp);
FInfoProc := CallBack;
end;
procedure TMyThread.Execute;
var
i:Integer;
begin
inherited;
for I := 1 to 10 do
begin
FMessage := Format('Info %d',[i]);
Synchronize(CallCallBack);
Sleep(200);
end;
end;
end.

Resources