Callbacks for Delphi, updated
In-place callbacks. Not really something very popular in classical Delphi programming, but wildly efficient and handy! In fact, I use them so much in Smart Mobile Studio that I missed them in Delphi — and as such I decided to implement them.
Oh and this is the second version, with some minor alteration from a previous post I did a while back.
So, what is it?
Right. Ever found yourself adding a TTimer to your main form because you want something to happen just after the form is shown and everything is ready? Or perhaps when a user clicks something there should be a small delay and then another thing should happen? I know I have. Especially when I want to setup something without taking to much of the OnFormShow() event. But the full onslaught of TComponent seems like overkill for such a tiny function doesnt it?
Either way, under Smart Mobile Studio I have a function initially called W3_Callback to deals with this. It simply creates a time object and keeps track of a procedure reference, and since it’s a one-liner you can use it to delay code execution and essentially allow for a breath of fresh air between calls. The method(s) takes two parameters: the first is the amount of time you want to wait, and the second a procedure you want to execute. So after calling w3_callback it starts a timer, counts down to zero, and then calls the function you provided.
Well, this unit does the same thing as it’s Smart Mobile counterpart. And it does wonders with anonymous procedures, allowing you to setup code to be executed “just after this”.
Note: This is for WinAPI only. If you port it for OS X please let me know, as I’m sure there are equivalent functions. So it shouldn’t be hard to make it portable (have a peek at TTimer under FMX perhaps?).
unit qtx.utils.callback; //############################################################################# // // Unit: Windows callback mechanism // Author: Jon Lennart Aasenden // Copyright: Jon Lennart Aasenden [LTD] // Org. Id: 913494741 // http://w2.brreg.no/enhet/sok/detalj.jsp?orgnr=913494741 //############################################################################# // // Purpose: // This unit provides methods for blocking delay of program execution, // and also a non-blocking callback function for anonymous methods. // // The TQTXCallback.Delay() method is blocking, meaning that it will halt // program execution for the duration of the MS parameter. // // The TQTXCallback.Callback() method is NON-blocking, meaning that it will // create a winAPI time object that, when the duration of MS is expired, // will execute the inline anonymous function. // // NOTE: There are two overloaded versions: One for anonymous methods, // and another for object methods (when used within a class). // // Example: // TQTXCallback.callback( // procedure ( // begin // showmessage('2 seconds have gone by'); // end, // 2000); // // // TQTXCallback.delay(nil,4000); // showmessage('4 seconds have gone by'); // // //############################################################################# interface uses System.SysUtils, System.Classes, Winapi.Windows, System.Generics.Collections; type TQTXObjectProc = procedure of Object; TQTXCallback = Class public (* Anonymous method implementation *) class procedure Callback(const aCallback:TProc;const ms:Cardinal);overload; class procedure Callback(const aCallback:TQTXObjectProc; const ms:Cardinal);Overload; class function CallbackEx(const aCallBack:TProc; const ms:Cardinal):THandle; class procedure AbortCallback(const aHandle:THandle); (* Object method implementation *) class procedure Delay(const aCallback:TProc;const ms:Cardinal);overload; class Procedure Delay(const aCallback:TQTXObjectProc; const ms:Cardinal);overload; end; implementation uses Vcl.Forms; var _LUT: TDictionary<UINT,TProc>; { TQTXCallback } class procedure TQTXCallback.Callback(const aCallback: TProc; const ms: Cardinal); procedure w3_invoke(hwnd: HWND; uMsg: UINT; idEvent: UINT_PTR;dwTime: DWORD);stdcall; var mProc: TProc; begin KillTimer(0,idEvent); try if assigned(_LUT) then begin mproc:=_lut.Items[idEvent]; _lut.Remove(idEvent); if assigned(mProc) then mproc; end; except on exception do; end; end; begin if Assigned(_LUT) then _LUT.add(SetTimer(0,0,ms,@w3_invoke),aCallback); end; class function TQTXCallback.CallbackEx(const aCallBack: TProc; const ms: Cardinal): THandle; procedure w3_invoke(hwnd: HWND; uMsg: UINT; idEvent: UINT_PTR;dwTime: DWORD);stdcall; var mProc: TProc; begin KillTimer(0,idEvent); try if assigned(_LUT) then begin mproc:=_lut.Items[idEvent]; _lut.Remove(idEvent); if assigned(mProc) then mproc; end; except on exception do; end; end; begin result:=0; if Assigned(_LUT) then Begin result:=SetTimer(0,0,ms,@w3_invoke); _LUT.Add(result,aCallback); end; end; class procedure TQTXCallback.AbortCallback(const aHandle: THandle); begin if assigned(_LUT) and _LUT.ContainsKey(aHandle) then begin _lut.Remove(aHandle); KillTimer(0,aHandle); end; end; class procedure TQTXCallback.Callback(const aCallback: TQTXObjectProc; const ms: cardinal); procedure w3_invoke(hwnd: HWND; uMsg: UINT; idEvent: UINT_PTR;dwTime: DWORD);stdcall; var mProc: TProc; begin KillTimer(0,idEvent); try if assigned(_LUT) then begin mproc:=_lut.Items[idEvent]; _lut.Remove(idEvent); if assigned(mProc) then mproc; end; except on exception do; end; end; begin if Assigned(_LUT) then _LUT.add(SetTimer(0,0,ms,@w3_invoke),aCallback); end; class procedure TQTXCallback.Delay(const aCallback: TProc; const ms: cardinal); var mThen: DWord; begin if assigned(application) and not application.Terminated and (ms>0) then Begin try mThen:=getTickCount + ms; repeat Sleep(1); if assigned(application) and application.Terminated then break; until getTickCount>=mThen; if assigned(aCallback) and Assigned(Application) and not (application.Terminated) then aCallback; except on exception do; end; end; end; class procedure TQTXCallback.Delay(const aCallback: TQTXObjectProc; const ms:Cardinal); var mThen: DWord; begin if assigned(application) and not application.Terminated and (ms>0) then Begin try mThen:=getTickCount + ms; repeat Sleep(1); if assigned(application) and application.Terminated then break; until getTickCount>=mThen; if assigned(aCallback) and Assigned(Application) and not (application.Terminated) then aCallback; except on exception do; end; end; end; initialization _LUT:=TDictionary<UINT,TProc>.Create; finalization if Assigned(_LUT) then FreeAndNil(_LUT); end.
Leave a Reply Cancel reply
Recent
The vatican vault
- January 2022
- October 2021
- March 2021
- November 2020
- September 2020
- July 2020
- June 2020
- April 2020
- March 2020
- February 2020
- January 2020
- November 2019
- October 2019
- September 2019
- August 2019
- July 2019
- June 2019
- May 2019
- April 2019
- March 2019
- February 2019
- January 2019
- December 2018
- November 2018
- October 2018
- September 2018
- August 2018
- July 2018
- June 2018
- May 2018
- April 2018
- March 2018
- February 2018
- January 2018
- December 2017
- November 2017
- October 2017
- August 2017
- July 2017
- June 2017
- May 2017
- April 2017
- March 2017
- February 2017
- January 2017
- December 2016
- November 2016
- October 2016
- September 2016
- August 2016
- July 2016
- June 2016
- May 2016
- April 2016
- March 2016
- January 2016
- December 2015
- November 2015
- October 2015
- September 2015
- August 2015
- June 2015
- May 2015
- April 2015
- March 2015
- February 2015
- January 2015
- December 2014
- November 2014
- October 2014
- September 2014
- August 2014
- July 2014
- June 2014
- May 2014
- April 2014
- March 2014
- February 2014
- January 2014
- December 2013
- November 2013
- October 2013
- September 2013
- August 2013
- July 2013
- June 2013
- May 2013
- February 2013
- August 2012
- June 2012
- May 2012
- April 2012
AFAIK it would work only for UI applications, not stand alone services. Unless you have a Windows messages processing loop in the main thread.
Yes it’s only written for VCL UI apps, not services. That would require a HWND at the very least.