Link to home
Create AccountLog in
Avatar of aburgoyne
aburgoyne

asked on

Emulating a TTimer with a thread in a Delphi DLL

Hia all... hopefully some of you have got tired of just eating and drinking this New Year weekend and want to flex your grey cells :-)

I have a "script interpreter" application that uses a Delphi DLL I've written for additional functionality.

Part of the DLL functionality is connecting to a custom TCP server to receive messages for the script.

I'm trying to avoid coding an endless loop within the script interpreter to force the script to go and check for new messages as that solves the immediate problem but creates a bunch of others so what I'd prefer to do is somehow emulate a TTimer within the DLL that sends a Windows message to the script interpreter every so often to wake it up and re-run the script.

I've seen the method used with a C++ DLL but I need a Delphi solution.

The basic principle is registering a Windows message within the DLL i.e.

MessageID := RegisterWindowMessageA('Unique_Internal_Message');

...then calling a "StartTimer" function from the script and passing in the Window handle of the target window and the timer frequency, i.e.

TimerStart(Handle, Frequency)

Once started, the timer function needs to run something like...

PostMessageA(Handle, MessageID, 0, 0);

...then pause for "Frequency" milliseconds before repeating.

I did find some code here on EE (https://www.experts-exchange.com/questions/20793467/Thread-in-Dll's.html) that seemed to do what I wanted but I've added it to my DLL and it just isn't triggering beyond the initial call.

Fingers crossed that someone has a solution :-)

regards, Adam
Avatar of Ephraim Wangoya
Ephraim Wangoya
Flag of United States of America image

You can use a callback procedure instead, Pass the call back procedure and the interval to the dll which will start a thread that will query the information you need.

Here is a simple example of how to do that, there are two projects, the main application and the dll.
It simply adds a status received from the dll thread to a listbox
library ThreadDll;

{ Important note about DLL memory management: ShareMem must be the
  first unit in your library's USES clause AND your project's (select
  Project-View Source) USES clause if your DLL exports any procedures or
  functions that pass strings as parameters or function results. This
  applies to all strings passed to and from your DLL--even those that
  are nested in records and classes. ShareMem is the interface unit to
  the BORLNDMM.DLL shared memory manager, which must be deployed along
  with your DLL. To avoid using BORLNDMM.DLL, pass string information
  using PChar or ShortString parameters. }

uses
  SysUtils,
  Classes,
  DllTypes in 'DllTypes.pas';

{$R *.res}

exports
  StartThread,
  StopThread,
  IsThreadRunning;

begin
end.

Open in new window

unit DllTypes;

interface

uses
  SysUtils, Classes, Math;

type
  TCallBackProc = procedure(const Status: Integer); stdcall;

  TThreadDll = class(TThread)
  private
    FInterval: Integer; //milliseconds
    FProc: TCallBackProc;
  public
    constructor Create(AProc: TCallBackProc; AInterval: Integer);
    procedure Execute; override;
  end;

function StartThread(ACallBack: TCallBackProc; AInterval: Integer): Boolean; stdcall;
procedure StopThread; stdcall;
function IsThreadRunning: Boolean; stdcall;

implementation

var
  GlobalThread: TThreadDll = nil;

function StartThread(ACallBack: TCallBackProc; AInterval: Integer): Boolean; stdcall;
begin
  StopThread;
  try
    GlobalThread := TThreadDll.Create(ACallBack, AInterval);
    Result := True;
  except
    FreeAndNil(GlobalThread);
    Result := False;
  end;
end;

procedure StopThread; stdcall;
begin
  if Assigned(GlobalThread) then
  begin
    GlobalThread.Terminate;
    FreeAndNil(GlobalThread);
  end;
end;

function IsThreadRunning: Boolean; stdcall;
begin
  Result := Assigned(GlobalThread) and (not GlobalThread.Terminated);
end;

{ TThreadDll }

constructor TThreadDll.Create(AProc: TCallBackProc; AInterval: Integer);
begin
  FInterval := IfThen(AInterval <= 0, 60*1000, AInterval);
  FProc := AProc;
  inherited Create(False);
end;

procedure TThreadDll.Execute;
var
  Status: Integer;
begin
  Status := 0;
  while not Terminated do
  begin
    Inc(Status);
    FProc(Status);
    Sleep(FInterval);
  end;
end;

initialization

finalization
  StopThread;

end.

Open in new window

unit Unit3;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

const
  UM_THEAD_MESSAGE = WM_USER + 101;

type
  TForm3 = class(TForm)
    Start: TButton;
    Stop: TButton;
    ListBox1: TListBox;
    procedure StartClick(Sender: TObject);
    procedure StopClick(Sender: TObject);
  private
    FThreadHandle: THandle;
    procedure UMTHEADMESSAGE(var Message: TMessage); message UM_THEAD_MESSAGE;
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}
type
  TCallBackProc = procedure(const Status: Integer); stdcall;
  TStartFunc = function(ACallBack: TCallBackProc; AInterval: Integer): Boolean; stdcall;
  TStopFunc = procedure; stdcall;

procedure CallBack(const Status: Integer); stdcall;
begin
  PostMessage(Form3.Handle, UM_THEAD_MESSAGE, Status, 0);
end;

procedure TForm3.StartClick(Sender: TObject);
var
  StartFunc: TStartFunc;
begin
  FThreadHandle := LoadLibrary(PChar('ThreadDll.dll'));
  if FThreadHandle <= 0 then
    raise Exception.Create('Unable to load dll');

  @StartFunc := GetProcAddress(FThreadHandle, PChar('StartThread'));
  if @StartFunc <> nil then
    StartFunc(CallBack, 1000);

  Start.Enabled := False;
end;

procedure TForm3.StopClick(Sender: TObject);
var
  StopFunc: TStopFunc;
begin
  if FThreadHandle > 0 then
  begin
    @StopFunc := GetProcAddress(FThreadHandle, PChar('StopThread'));
    if Assigned(@StopFunc) then
      StopFunc();
    FreeLibrary(FThreadHandle);
    FThreadHandle := 0;

    Start.Enabled := True;
  end;
end;

procedure TForm3.UMTHEADMESSAGE(var Message: TMessage);
begin
  ListBox1.Items.Add(IntToStr(Message.WParam));
end;

end.

Open in new window

object Form3: TForm3
  Left = 0
  Top = 0
  Caption = 'Form3'
  ClientHeight = 202
  ClientWidth = 367
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Start: TButton
    Left = 24
    Top = 160
    Width = 75
    Height = 25
    Caption = 'Start'
    TabOrder = 0
    OnClick = StartClick
  end
  object Stop: TButton
    Left = 120
    Top = 160
    Width = 75
    Height = 25
    Caption = 'Stop'
    TabOrder = 1
    OnClick = StopClick
  end
  object ListBox1: TListBox
    Left = 24
    Top = 8
    Width = 329
    Height = 137
    ItemHeight = 13
    TabOrder = 2
  end
end

Open in new window

You can do that with TThread I think.
Here are some portions of the code I would use or adapt.


type

  ThreadState = (RUNNINGSTATE, SUSPENDSTATE, STOPSTATE);


  TPollThread = class(TThread)
  public
  private
  protected
    procedure Execute; override;
  end;


var
  PollSemaphore: THandle;
  PollThread: TProllThread;
  DoRun: boolean;
  NbOfSecondsLoop: DWORD;


procedure Ansi2Ascii(var s: string);
var s0: string;
begin
  Setlength(s0,length(s));
  if length(s0)>0 then
    CharToOem(Pchar(s),Pchar(s0));
  s:=s0;
end;

function ErrorToText(ErrorNum: DWORD):string;
var
  dwSize:DWORD;
  lpszTemp:LPSTR;
  S: string;
begin
  dwSize:=512;
  lpszTemp:=nil;
  try
    GetMem(lpszTemp,dwSize);
    FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY,
      nil,ErrorNum,LANG_NEUTRAL,lpszTemp,dwSize,nil);
  finally
    S:=StrPas(lpszTemp);
    Ansi2Ascii(S);
    Result:=S;
    FreeMem(lpszTemp);
  end;
end;

function GetLastErrorText:string;
begin
  Result:=ErrorToText(GetLastError);
end;


procedure TPollThread.Execute;
var
  WaitResult: Integer;
begin
try
  while true do
  begin
      while StaThread = SUSPENDSTATE do
          Sleep(1000);
      if StaThread = STOPSTATE then
          break;
      if Terminated then break;

      WaitResult := WaitForSingleObject(PollSemaphore, INFINITE);
      case WaitResult of
         WAIT_OBJECT_0:
         begin
           {$ifdef DEBUG}
           OutputDebugString('Task Thread Executing');
           {$endif}

           (* Your code here. It will be executed when you acquire the Semaphore *)

           {$ifdef DEBUG}
           OutputDebugString('Task Thread Finished');
           {$endif}

         end;
         WAIT_TIMEOUT: ;
         WAIT_ABANDONED: ;
       end;
  end;
except
  on E:Exception do  OutputDebugString('Exception in TPollThread.Execute: '+E.Message);
end;
end;


...

begin
    DoRun:=True;
    NbOfSecondsLoop=8; (*the thread will "poll" every NbOfSecondsLoop);

    PollSemaphore:=CreateSemaphore(nil,0,1,'');
    if PollSemaphore=0 then
    begin
        OutputDebugString('Could not create its tasks semaphore on second attempt. Error:+GetLastErrorText);
        ExitProcess($FFFFFFFF);
      end;
    end;

  while DoRun do
  begin
    (** Semaphore for launching the thread **)
    ReleaseSemaphore(PollSemaphore,1,nil);
    for I :=1 to  NbOfSecondsLoop do
    begin
      Sleep(1000);
      (* add "CheckMessage" code here, such as Application.ProcessMessages *)
      if not DoRun then break;
    end;
  end;
end.

nice one ewangoya, ... there is something odd with your naming though :)

implementation

var
  GlobalThread: TThreadDll = nil;

This thread isn't global, it's only for the implementation part of the DllTypes unit
so it's actually a
var
  DllTypesThread: TThreadDll = nil;
@Geert_Gruwez
Very true, thanks
ewangoya ...
you can only have 1 timer running in your dll

it's only a sample, i know ... but still
ASKER CERTIFIED SOLUTION
Avatar of lomo74
lomo74
Flag of Italy image

Link to home
membership
Create an account to see this answer
Signing up is free. No credit card required.
Create Account
Adam, is this question abandoned?
Avatar of aburgoyne
aburgoyne

ASKER

no - just been travelling - couldn't get the initial code examples to work but the last one looks good.

Adam