Delphi XE5 - Threads and memory leak when operation on TBitmap - delphi

Application works as I'd like but there are quite big memory leakage.
Every event that throttles one thread gives me 4 TBitmaps and 2 TStrokeBrush that are lost.
The procedure DrawSine(); is triggered in Execute in Synchronize statement:
procedure SineThread.DrawSine();
var
sin_T : Extended;
Point2 : TPoint;
I : Integer;
begin
TempBitmap.SetSize(Twidth, Theight);
TempBitmap.Canvas.BeginScene();
TempBitmap.Canvas.Stroke.Kind := TBrushKind.bkSolid;
TempBitmap.Canvas.Stroke.Color := claLime;
TempBitmap.Canvas.Clear(TAlphaColorRec.Black);
for I := 0 to Twidth do
begin
sin_T := Sin(((I - Tphas)/100.0) * Tfreq);
Point2.X := Round(I);
Point2.Y := Round(sin_T * Tampl) + Round(Theight/2.0);
if I = 0 then
begin
Point1.X := Round(I);
Point1.Y := Round(sin_T * Tampl) + Round(Theight/2.0);
TempBitmap.Canvas.DrawLine(Point1, Point2, 1.0, TempBrush);
end
else
begin
if I = Twidth then
begin
TempBitmap.Canvas.DrawLine(Point1, Point2, 1.0, TempBrush);
Point1.X := Round(I);
Point1.Y := Round(Theight/2.0);
end
else
begin
TempBitmap.Canvas.DrawLine(Point1, Point2, 1.0, TempBrush);
Point1.X := Point2.X;
Point1.Y := Point2.Y;
end;
end;
end;
TempBitmap.Canvas.EndScene();
end;
SineThread Constructor and Destructor:
constructor SineThread.Create(CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
try
TempBitmap := TBitmap.Create();
TempBrush := TStrokeBrush.Create(TBrushKind.bkSolid, TAlphaColorRec.White);
finally
Twidth := 0;
Theight := 0;
Tampl := 0;
Tphas := 0;
Tfreq := 0;
Point1 := Point(0,0);
end;
end;
destructor SineThread.Destroy();
begin
inherited Destroy();
TempBitmap.Free();
TempBrush.Free();
end;
OnTerminate when finishing thread looks like:
procedure TForm1.OnTerminateProc1(Sender: TObject);
var
TempStream : TMemoryStream;
begin
try
TempStream := TMemoryStream.Create();
finally
(Sender as SineThread).GetBitmap.SaveToStream(TempStream);
Image1.Bitmap.LoadFromStream(TempStream);
TempStream.Free();
end;
end;
The Trigger() procedure is started every the the value on TrackBars change:
procedure TForm1.Trigger(Sender: TObject);
var
sine1_thread : SineThread;
sine2_thread : SineThread;
sineSum_thread : SineSumThread;
begin
try
begin
sine1_thread := SineThread.Create(True);
sine2_thread := SineThread.Create(True);
sineSum_thread := SineSumThread.Create(True);
end;
finally
begin
sine1_thread.SetSineParams(TrackBar1.Value, TrackBar2.Value, TrackBar3.Value);
sine1_thread.SetImageParams(Trunc(Image1.Width), Trunc(Image1.Height));
sine1_thread.FreeOnTerminate := True;
sine1_thread.OnTerminate := OnTerminateProc1;
sine1_thread.Start();
sine2_thread.SetSineParams(TrackBar4.Value, TrackBar5.Value, TrackBar6.Value);
sine2_thread.SetImageParams(Trunc(Image2.Width), Trunc(Image2.Height));
sine2_thread.FreeOnTerminate := True;
sine2_thread.OnTerminate := OnTerminateProc2;
sine2_thread.Start();
sineSum_thread.SetSineParams(TrackBar1.Value, TrackBar2.Value, TrackBar3.Value, TrackBar4.Value, TrackBar5.Value, TrackBar6.Value);
sineSum_thread.SetImageParams(Trunc(Image3.Width), Trunc(Image3.Height));
sineSum_thread.FreeOnTerminate := True;
sineSum_thread.OnTerminate := OnTerminateProc3;
sineSum_thread.Start();
end;
end;
end;

It seems that the threads are not being destroyed. Since they are freed on terminate that seems odd. You set FreeOnTerminate, so if the threads terminate they will be destroyed.
Let us assume that the threads to terminate. In which case the explanation is that your destructor is missing override directive. It should be declared like this:
destructor Destroy; override;
My psychic debugging skills (not infallible) tell me that you missed the override. So when Destroy is called, the base class method runs and not yours.
The most effective way to track down leaks is to use the full version of FastMM. When configured correctly that will give stack traces for the allocation associated with a leak. And lots of other useful stuff to help find defects earlier.
Don't use finally in a constructor's implementation. If an exception is raised then, the instance will be destroyed and so your finally block is pointless.
Use the correct resource acquisition pattern:
obj := TMyClass.Create;
try
obj.Foo; // do stuff with obj
finally
obj.Free;
end;
As you write it, an exception raise in the constructor will lead to you calling Free on an uninitialized instance variable.
Deallocate resource in reverse order to their acquisition. That means that your destructor should be written:
destructor SineThread.Destroy;
begin
TempBrush.Free;
TempBitmap.Free;
inherited;
end;
The finally in TForm1.Trigger is also wrong. A finally block runs no matter what. If for some reason you fail to create an object, you must not carry on as if that failure did not happen. You use finally to protect a resource. You acquire a resource, and use the finally block to make sure that you release it no matter what.
There's absolutely no need for threads in your program. As you explained in your previous question, and mentioned again here, you use Synchronize to put all the work onto the main threads. This renders the threads nugatory. I don't know why you chose to use threads. Perhaps you thought that by doing so, your program would perform better. That is not always the case, and certainly not when you implement threading the way you have done.
Programming is hard enough at the best of times, without needless complexity. Especially when you have not yet mastered the language. My advice is to do that first before moving on to advanced topics like threading.
Finally, you must learn to present complete, but cut-down examples for questions like this. You omitted quite a bit of code, and if I am right, the most important bit of code, that which causes the leak, was omitted.

One general rule to remember is this one:
When an object's constructor raises an exception, it's destructor is
called automatically.
So the try..finally sequence in SineThread.Create is not needed.
In an object's destructor, call inherited as last item.
constructor SineThread.Create(CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
TempBitmap := TBitmap.Create();
TempBrush := TStrokeBrush.Create(TBrushKind.bkSolid, TAlphaColorRec.White);
Twidth := 0;
Theight := 0;
Tampl := 0;
Tphas := 0;
Tfreq := 0;
Point1 := Point(0,0);
end;
destructor SineThread.Destroy();
begin
TempBitmap.Free();
TempBrush.Free();
inherited;
end;
same goes for OnTerminateProc1 :
procedure TForm1.OnTerminateProc1(Sender: TObject);
var
TempStream : TMemoryStream;
begin
TempStream := TMemoryStream.Create();
try
(Sender as SineThread).GetBitmap.SaveToStream(TempStream);
Image1.Bitmap.LoadFromStream(TempStream);
finally
TempStream.Free();
end;
end;
no need for try..finally inTrigger() :
procedure TForm1.Trigger(Sender: TObject);
var
sine1_thread : SineThread;
sine2_thread : SineThread;
sineSum_thread : SineSumThread;
begin
sine1_thread := SineThread.Create(True);
sine2_thread := SineThread.Create(True);
sineSum_thread := SineSumThread.Create(True);
sine1_thread.SetSineParams(TrackBar1.Value, TrackBar2.Value, TrackBar3.Value);
sine1_thread.SetImageParams(Trunc(Image1.Width), Trunc(Image1.Height));
sine1_thread.FreeOnTerminate := True;
sine1_thread.OnTerminate := OnTerminateProc1;
sine1_thread.Start();
sine2_thread.SetSineParams(TrackBar4.Value, TrackBar5.Value, TrackBar6.Value);
sine2_thread.SetImageParams(Trunc(Image2.Width), Trunc(Image2.Height));
sine2_thread.FreeOnTerminate := True;
sine2_thread.OnTerminate := OnTerminateProc2;
sine2_thread.Start();
sineSum_thread.SetSineParams(TrackBar1.Value, TrackBar2.Value, TrackBar3.Value, TrackBar4.Value, TrackBar5.Value, TrackBar6.Value);
sineSum_thread.SetImageParams(Trunc(Image3.Width), Trunc(Image3.Height));
sineSum_thread.FreeOnTerminate := True;
sineSum_thread.OnTerminate := OnTerminateProc3;
sineSum_thread.Start();
end;

Related

Why in Firemonkey when create controls at runtime are display when finish iteration?

I create over 100 rectangles at runtine in code below;
var
RectT: TRectangle;
MyThread: TThread;
Layout1: TLayout;
begin
MyThread := TThread.CreateAnonymousThread(procedure()
begin
TThread.Synchronize(nil, procedure()
var
z, i: integer;
begin
z := 0;
for i := 0 to 99 do
begin
RectT := TRectangle.Create(Self);
RectT.Name := 'Rectangle' + IntToStr(i);
RectT.Align := TAlignLayout.Top;
RectT.Margins.Top := 6;
RectT.Position.Y := z;
RectT.Height := 20;
RectT.Parent := Layout1;
if (i mod 10) = 0 then Layout1.UpdateEffects;
inc(z, 20);
end;
end);
end);
MyThread.FreeOnTerminate := True;
MyThread.Start;
end;
Why didn't display the rectangle when is created and only are displayed when finish the iteration of all rectangles?.
First, you need to move the for loop in one thread and the creation of the rectangles in a Synchronize call, as Deltics has done. The difference is that you do not need the call to Repaint and you need to use the currentthread to pass the call for synchronization.
Try this (in OnClick event of a Button):
procedure TForm4.Button1Click(Sender: TObject);
begin
TThread.CreateAnonymousThread(procedure
var
I,z: Integer;
Total: Integer;
begin
Total := 0;
for I := 1 to 99 do
begin
TThread.Synchronize (TThread.CurrentThread,
procedure
var
RectT: TRectangle;
begin
RectT := TRectangle.Create(Self);
RectT.Name := 'Rectangle' + IntToStr(i);
RectT.Align := TAlignLayout.Top;
RectT.Margins.Top := 6;
RectT.Position.Y := z;
RectT.Height := 20;
RectT.Parent := Layout1;
Inc(z, 20);
end);
end;
end).Start;
end;
If this code is running on the main thread (which appears to be the case since you don't mention any threading) then the first opportunity that the FMX runtime has of visually updating the UI is when your code has itself finished running.
If you want the UI to update to display the rectangles as they are added, then you will need to re-write this to use an approach that allows the UI an opportunity to repaint periodically.
UPDATE
Your updated code in the question now involves a thread. However, in your posted code you Synchronize() all of the work in that thread. Synchronized code runs in the main thread so the consequence of synchronizing all of the work is to remove any benefit of the thread at all.
You are nearly there however.
A small change to your posted code so that the layout child objects are added in the thread, synchronizing only the repainting of the layout object itself periodically, then you get the result you are seeking:
var
MyThread: TThread;
begin
MyThread := TThread.CreateAnonymousThread
(
procedure()
var
z, i: integer;
RectT: TRectangle;
begin
z := 0;
for i := 0 to 999 do
begin
RectT := TRectangle.Create(Self);
RectT.Name := 'Rectangle' + IntToStr(i);
RectT.Align := TAlignLayout.Top;
RectT.Margins.Top := 6;
RectT.Position.Y := z;
RectT.Height := 20;
RectT.Parent := Layout1;
TThread.Synchronize(nil, procedure()
begin
Layout1.Repaint;
end);
inc(z, 20);
end;
end
);
MyThread.FreeOnTerminate := True;
MyThread.Start;
end;
I have increased the number of child objects in this demonstration of the approach to 999 since 99 was not enough to see any appreciable change in performance.
As written, the above code also repaints after every rectangle has been added, but this could be easily modified in a way similar to your posted code so that the layout is repainted only after "batches" of rectangles have been added:
if (i mod 10) = 0 then
TThread.Synchronize(nil, procedure()
begin
Layout1.Repaint;
end);
This is a simplistic approach, addressing the immediate problem of updating the UI to show the progress of some background changes made to that UI using this very simple test case. Whether this is actually the most appropriate approach in your specific case only you can really say.

Left side cannot be assigned for a record type

I am trying to upgrade my application from Delphi 2007 to Delphi 10 Seattle. I understand that a record needs to be copied to a local variable before changing and then assigned back. I am trying the same but I still get the error that I cannot assign to a left side. Could someone please help.
procedure TMydlg.WMGetMinMaxInfo(var Msg:TMessage);
var
MinMaxInfo: TMinMaxInfo;
begin
inherited;
MinMaxInfo := (PMinMaxInfo(Msg.LParam)^);
with MinMaxInfo do
begin
ptMinTrackSize.X := MinWidth;
ptMinTrackSize.Y := MinHeight;
ptMaxTrackSize.X := MinWidth;
end;
// Error here. Left side cannot be assigned to
(PMinMaxInfo(Msg.LParam)^) := MinMaxInfo;
TMinMaxInfo is from Winapi.windows
The compiler error is emitted because the compiler rejects the outermost parens on the left hand side of the final assignment. In essence, your code is akin to the following:
type
TMyRecord = record
end;
procedure Foo;
var
rec1, rec2: TMyRecord;
begin
rec1 := rec2; // compiles
(rec1) := rec2; // E2064 Left side cannot be assigned to
end;
Writing it in this simplified manner brings the issue into very sharp relief.
I'm not sure why the compiler rejects these parens. I suspect that the formal grammar of the language renders your left hand side invalid. Serg provides a plausible explanation in the comments, that is that (...) is an expression, and an expression is not valid as the left hand side of an assignment. I'm inclined to believe that is accurate.
Anyway, it is simple to fix your code. Instead of
(PMinMaxInfo(Msg.LParam)^) := MinMaxInfo;
write
PMinMaxInfo(Msg.LParam)^ := MinMaxInfo;
Note that it is not necessary to make a copy of the record, modify it, and then copy it back. You can modify the record directly, once you have cast LParam to a pointer to the record.
I would do so like this:
procedure TMydlg.WMGetMinMaxInfo(var Msg:TMessage);
var
pmmi: PMinMaxInfo;
begin
inherited;
pmmi := PMinMaxInfo(Msg.LParam);
pmmi.ptMinTrackSize.X := MinWidth;
pmmi.ptMinTrackSize.Y := MinHeight;
pmmi.ptMaxTrackSize.X := MinWidth;
end;
I've omitted the ^ pointer dereference operator since it is optional in this scenario. If you prefer you might write the assignments like this:
pmmi^.ptMinTrackSize.X := MinWidth;
pmmi^.ptMinTrackSize.Y := MinHeight;
pmmi^.ptMaxTrackSize.X := MinWidth;
It is because you do not use a Record type and not a pointer type.
Change your code to this:
procedure TMydlg.WMGetMinMaxInfo(var Msg: TMessage);
begin
with pMinMaxInfo(Msg.LParam)^ do
begin
ptMinTrackSize.X := MinWidth;
ptMinTrackSize.Y := MinHeight;
ptMaxTrackSize.X := MinWidth;
end;
end;
I've created a dummy test program:
procedure TForm9.FormCreate(Sender: TObject);
var
MinMaxInfo: pMinMaxInfo;
Msg: TMessage;
begin
MinMaxInfo := new(pMinMaxInfo);
Msg.LParam := integer(MinMaxInfo);
WMGetMinMaxInfo(Msg);
Assert( pMinMaxInfo(Msg.LParam)^.ptMinTrackSize.X = 10);
end;
procedure TForm9.WMGetMinMaxInfo(var Msg: TMessage);
var
MinMaxInfo: pMinMaxInfo;
begin
MinMaxInfo := pMinMaxInfo(Msg.LParam);
with MinMaxInfo^ do
begin
ptMinTrackSize.X := 10;
ptMinTrackSize.Y := 10;
ptMaxTrackSize.X := 10;
end;
end;

TIdHttp freezes when the internet gets slower

How to avoid freezing the idHTTP when the internet become slower or no connectivity. My application get freeze and I could not even close the form.
This is how I setup my code
procedure TDownloader.IdHTTPWork(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Int64);
var
lwElapsedMS: LongWord;
iBytesTransferred: Int64;
iBytesPerSec: Int64;
iRemaining: Integer;
begin
if AWorkMode <> wmRead then Exit;
lwElapsedMS := GetTickDiff(FLastTicks, Ticks);
if lwElapsedMS = 0 then lwElapsedMS := 1; // avoid EDivByZero error
if FTotalBytes > 0 then
FPercentDone := Round(AWorkCount / FTotalBytes * 100.0)
else
FPercentDone := 0;
iBytesTransferred := AWorkCount - FLastWorkCount;
iBytesPerSec := Round(iBytesTransferred * 1000 / lwElapsedMS);
if Assigned(OnDownloadProgress) then
begin
if FContinueDownload <> 0 then //previous file downloaded
begin
iRemaining := 100 - FContinueDownload;
iRemaining := Round(FPercentDone * iRemaining / 100);
OnDownloadProgress(Self, FContinueDownload + iRemaining, AWorkCount, FTotalBytes, iBytesPerSec);
end else
OnDownloadProgress(Self, FPercentDone, AWorkCount, FTotalBytes, iBytesPerSec);
end;
FLastWorkCount := AWorkCount;
FLastTicks := Ticks;
if FCancel then
begin
Abort;
TidHttp(ASender).Disconnect;
end;
end;
procedure TDownloader.IdHTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
AWorkCountMax: Int64);
begin
if AWorkMode <> wmRead then Exit;
FPercentDone := 0;
FTotalBytes := AWorkCountMax;
FLastWorkCount := 0;
FLastTicks := Ticks;
end;
procedure TDownloader.IdHTTPWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
begin
if AWorkMode <> wmRead then Exit;
if Assigned(OnDownloadComplete) and (FPercentDone >= 100) then
OnDownloadComplete(Self)
else if Assigned(OnDownloadCancel) then
OnDownloadCancel(Self);
end;
function TDownloader.EXDownload(AURL, ADestFile: String;
AAutoDisconnect: Boolean): Boolean;
var
fsBuffer: TFileStream;
idHttp: TIdHttp;
begin
if FileExists(ADestFile) then
fsBuffer := TFileStream.Create(ADestFile, fmOpenReadWrite)
else
fsBuffer := TFileStream.Create(ADestFile, fmCreate);
fsBuffer.Seek(0, soFromEnd);
try
idHttp := TIdHttp.Create(nil);
idHttp.OnWorkBegin := idHttpWorkBegin;
idHttp.OnWork := idHttpWork;
idHttp.OnWorkEnd := idHttpWorkEnd;
idHttp.Request.CacheControl := 'no-store';
try
...
idHttp.Get(AURL, fsBuffer);
...
finally
idHttp.Free;
end;
finally
fsBuffer.Free;
end;
end;
......
procedure TDownloader.Execute;
begin
Inherited;
while not Terminated do
begin
if FUrl <> '' then
begin
EXDownload(FUrl, FFilename, True);
end;
end;
end;
...
on the main form progress
procedure TfrmDownloadList.DownloadProgress(Sender: TObject; aPercent:Integer;
aProgress, aProgressMax, aBytesPerSec: Int64);
var
yts: PYoutubeSearchInfo;
begin
if Assigned(FCurrentDownload) then
begin
yts := vstList.GetNodeData(FCurrentDownload);
yts.Tag := aPercent;
ProgressBar.Position := aPercent;
vstList.InvalidateNode(FCurrentDownload);
StatusBar.Panels.Items[1].Text := 'Download: ' + FormatByteSize(aProgress) + '/' +
FormatByteSize(aProgressMax);
StatusBar.Panels.Items[2].Text := 'Speed: ' + FormatByteSize(aBytesPerSec) + 'ps';
Application.ProcessMessages;
end;
end;
I don't have problem when the internet is good only when it drops due to poor signal.
this is my app lookslike
If we assume that TDownloader.OnDownloadProgress is assigned to the TfrmDownloadList.DownloadProgress method, then your problem is that you are calling VCL code (your update of the progress bar) from a secondary thread (ie. not from the Main thread). This is not supported.
You'll need to wrap the call with a Synchronize statement from within your thread. Synchronize calls a parameterless method on the main thread. So you need to store the variables that are needed and then call Synchronize on a method in your TDownloader class that then calls on to TfrmDownloadList.DownloadProgress
You cannot call TfrmDownloadList.DownloadProgress directly or indirectly from within code that runs on another thread than the main thread, as it updates VCL objects, and the VCL is not thread-safe.
The same goes for your DownloadComplete event, if it updates any VCL objects...
How about you using TIdAntiFreeze ?
TIdAntiFreeze implements a GUI-integration class that ensures
processor time is allocated for the Application main thread.
Indy works on the blocking sockets model. Calls made to methods in the
Indy components do not return until they are complete. If calls are
made in the main thread, this will cause the Application User
Interface to "freeze" during Indy calls. TIdAntiFreeze counteracts
this effect.
TIdAntiFreeze allows Indy to process Application messages so that
Windows messages continue to be executed while Indy blocking socket
calls are in effect.
Only one TIdAntiFreeze can be active in an application.

How to ensure only a single instance of my application runs?

Is there support in the Delphi XE VCL for ensuring only a single instance of an application is running?
In the past, I've used library code to control a Mutex which has always seemed complicated. As I'm starting a new project in Delphi XE, I wonder if I need to dig up that old code, or if there is support built into XE already? Or is there another easy to apply code that is nice and modern?
You create a named Mutex when you start the application. Check GetLastError to see if an other instance is already running.
Put this code right after "begin" in your DPR file. Replace the GUID with one of your own. When I need a text constant that's unlikely to be used for anything else, I usually just hit Ctrl+G to get a GUID!
if CreateMutex(nil, True, '6EACD0BF-F3E0-44D9-91E7-47467B5A2B6A') = 0 then
RaiseLastOSError;
if GetLastError = ERROR_ALREADY_EXISTS then
Exit;
It might look like the code is leaking an handle because it's not saving the return of CreateMutex. It's not. Windows will automatically release the handle when our application is terminated, and that's absolutely fine with us.
I use JCL to do this:
program MyProgram;
uses
JclAppInst;
begin
JclAppInstances.CheckSingleInstance; // Added instance checking
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.
Documentation for this, and the notification scheme, is at the JCL Wiki.
I use this, works in XE2 through to Alexandria, has the benefit of being able to bring the currently running instance to the front.
Those that say it shouldn't do that, well, given the last thing the user did was to try launch the app, bringing a currently running instance to the front makes sense
unit CheckPrevious;
interface
uses
Windows, SysUtils, WinSock;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
implementation
type
PInstanceInfo = ^TInstanceInfo;
TInstanceInfo = packed record
PreviousHandle : THandle;
RunCounter : integer;
end;
var
MappingHandle: THandle;
InstanceInfo: PInstanceInfo;
MappingName : string;
RemoveMe : boolean = True;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
begin
Result := True;
MappingName := StringReplace(ParamStr(0),'\','',[rfReplaceAll, rfIgnoreCase]);
MappingHandle := CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,SizeOf(TInstanceInfo),PChar(MappingName));
if MappingHandle = 0 then
RaiseLastOSError
else
begin
if GetLastError <> ERROR_ALREADY_EXISTS then
begin
InstanceInfo := MapViewOfFile(MappingHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TInstanceInfo));
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1;
Result := False;
end
else //already runing
begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TInstanceInfo));
if InstanceInfo^.RunCounter >= MaxInstances then
begin
RemoveMe := False;
if IsIconic(InstanceInfo^.PreviousHandle) then
ShowWindow(InstanceInfo^.PreviousHandle, SW_RESTORE);
SetForegroundWindow(InstanceInfo^.PreviousHandle);
end
else
begin
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1 + InstanceInfo^.RunCounter;
Result := False;
end
end;
end;
end;
end;
initialization
finalization
//remove one instance
if RemoveMe then
begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle, FILE_MAP_ALL_ACCESS, 0, 0, SizeOf(TInstanceInfo));
InstanceInfo^.RunCounter := -1 + InstanceInfo^.RunCounter;
end
else
RaiseLastOSError;
end;
if Assigned(InstanceInfo) then
UnmapViewOfFile(InstanceInfo);
if MappingHandle <> 0 then
CloseHandle(MappingHandle);
end.
In your project DPR, add the CheckPrevious unit to the uses, then just after begin put the following
if RestoreIfRunning(Application.Handle, 1) then
Exit;
I have no idea of where this code originated, otherwise I would gladly credit the author. (A search of RestoreIfRunning may suggest it was from Zarko Gajic)
This is how i do it.
closeProc(extractfilename(paramstr(0)));
function TForm1.closeProc(pname : string): integer;
const
PROCESS_TERMINATE = $0001;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
i : integer;
pname2 : string;
begin
try
Result := 0;
i := 0;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while Integer(ContinueLoop) <> 0 do
begin
pname2 := trim(UpperCase(ExtractFileName(FProcessEntry32.szExeFile)));
if ( pname2 = uppercase(pname)) then
if FProcessEntry32.th32ProcessID <> GetCurrentProcessId then
begin
Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0), FProcessEntry32.th32ProcessID), 0));
inc(i);
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
if i > 50 then
break;
end;
CloseHandle(FSnapshotHandle);
except
end;
end;

Remove and Replace a visual component at runtime

Is it possible to, for instance, replace and free a TEdit with a subclassed component instantiated (conditionally) at runtime? If so, how and when it should be done? I've tried to set the parent to nil and to call free() in the form constructor and AfterConstruction methods but in both cases I got a runtime error.
Being more specific, I got an Access violation error (EAccessViolation). It seems François is right when he says that freeing components at frame costruction messes with Form controls housekeeping.
This more generic routine works either with a Form or Frame (updated to use a subclass for the new control):
function ReplaceControlEx(AControl: TControl; const AControlClass: TControlClass; const ANewName: string; const IsFreed : Boolean = True): TControl;
begin
if AControl = nil then
begin
Result := nil;
Exit;
end;
Result := AControlClass.Create(AControl.Owner);
CloneProperties(AControl, Result);// copy all properties to new control
// Result.Left := AControl.Left; // or copy some properties manually...
// Result.Top := AControl.Top;
Result.Name := ANewName;
Result.Parent := AControl.Parent; // needed for the InsertControl & RemoveControl magic
if IsFreed then
FreeAndNil(AControl);
end;
function ReplaceControl(AControl: TControl; const ANewName: string; const IsFreed : Boolean = True): TControl;
begin
if AControl = nil then
Result := nil
else
Result := ReplaceControlEx(AControl, TControlClass(AControl.ClassType), ANewName, IsFreed);
end;
using this routine to pass the properties to the new control
procedure CloneProperties(const Source: TControl; const Dest: TControl);
var
ms: TMemoryStream;
OldName: string;
begin
OldName := Source.Name;
Source.Name := ''; // needed to avoid Name collision
try
ms := TMemoryStream.Create;
try
ms.WriteComponent(Source);
ms.Position := 0;
ms.ReadComponent(Dest);
finally
ms.Free;
end;
finally
Source.Name := OldName;
end;
end;
use it like:
procedure TFrame1.AfterConstruction;
var
I: Integer;
NewEdit: TMyEdit;
begin
inherited;
NewEdit := ReplaceControlEx(Edit1, TMyEdit, 'Edit2') as TMyEdit;
if Assigned(NewEdit) then
begin
NewEdit.Text := 'My Brand New Edit';
NewEdit.Author := 'Myself';
end;
for I:=0 to ControlCount-1 do
begin
ShowMessage(Controls[I].Name);
end;
end;
CAUTION: If you are doing this inside the AfterConstruction of the Frame, beware that the hosting Form construction is not finished yet.
Freeing Controls there, might cause a lot of problems as you're messing up with Form controls housekeeping.
See what you get if you try to read the new Edit Caption to display in the ShowMessage...
In that case you would want to use
...ReplaceControl(Edit1, 'Edit2', False)
and then do a
...FreeAndNil(Edit1)
later.
You have to call RemoveControl of the TEdit's parent to remove the control. Use InsertControl to add the new control.
var Edit2: TEdit;
begin
Edit2 := TEdit.Create(self);
Edit2.Left := Edit1.Left;
Edit2.Top := Edit2.Top;
Edit1.Parent.Insertcontrol(Edit2);
TWinControl(Edit1.parent).RemoveControl(Edit1);
Edit1.Free;
end;
Replace TEdit.Create to the class you want to use, and copy all properties you need like I did with Left and Top.
You can actually use RTTI (look in the TypInfo unit) to clone all the matching properties. I wrote code for this a while back, but I can't find it now. I'll keep looking.

Resources