Eindeutiger Callback bei mehreren Instanzen des selben Programms

[MaxDelphi]

@himitsu

In der Kürze liegt die Würze, du hast die von mir umrissene Idee schön zusammengefaßt.

Hier jetzt der versprochene Quell-Code und Hinweise:
Man muss das Test-Programm mindestens zweimal aufrufen. Es zeigt dann den Handle aus der DLL an. Man muss dann diesen Handle über kreuz in den jeweiligen Target-Eingabefeldern eintragen. Danach kann man:
- Die LED direkt ein- und ausschalten.
- Die LED über Callback ein- und ausschalten.
- Die LED des Targets umschalten.
Achtung die Handles der anderen Anwendungen werden noch nicht über MMF verwaltet!!

Quellcode der DLL:

Delphi-Quellcode:

library cbDLL;

uses
   JclSysInfo, SysUtils
  ,Classes
  ,Forms
  ,Windows
  ,Messages
  ;

{$R *.res}

type
   // Definition des Callbacks
   TMyCallback = procedure (State: Integer); stdcall;

   // Klasse zum Senden und Empfangen von Botschaften.
   TMyForm = class(TCustomForm)
   private
      procedure MsgHandler(var Msg : TMessage); message WM_USER;
   end;

var
   TheCallback : TMyCallback;
   MyForm   : TMyForm;
   State: Boolean;
   SaveExit: Pointer;

// Auslösen des Callbacks
procedure OnOff(State: Integer);
begin
   if assigned(TheCallback) then
      TheCallback(State);
end;

// Einschalten
procedure CallOn; stdcall;
begin
   OnOff(1);
end;

// Ausschalten
procedure CallOff; stdcall;
begin
   OnOff(0);
end;

// Botschaft empfangen
procedure TMyForm.MsgHandler(var Msg : TMessage);
begin
   State := not State;
   if State then
      CallOn
   else
      CallOff;
end;

// Callback Initialisieren.
procedure Init(cb: TMyCallback); stdcall;
begin
   TheCallback := cb;
end;

// Eigenen Handle ermitteln; Adresse an die man senden kann.
function GetHandle: Longword; stdcall;
begin
   result   := MyForm.Handle;
end;

// Botschaft senden.
procedure Post(Target: Longword); stdcall;
begin
   PostMessage(Target, WM_USER, 0, 0);
end;

// Freigeben von Ressourcen
procedure LibExit;
begin
   MyForm.Free;
   // ... als letzte Anweisung
   ExitProc := SaveExit;  // Kette der Exit-Prozeduren wiederherstellen
end;

// Export-Tabelle
exports
    Init
   ,CallOn
   ,CallOff
   ,GetHandle
   ,Post
   ;

// Initialisierung
begin
   // ... als erste Anweisungen
   SaveExit := ExitProc;  // Kette der Exit-Prozeduren speichern
   ExitProc := @LibExit;  // Exit-Prozedur LibExit installieren
   State := False;
   MyForm   := TMyForm.CreateNew(nil);
end.

Quellcode der Testanwendung:

Delphi-Quellcode:

unit Unit1;

interface

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

type

   TFunc = procedure(State: Integer); stdcall;

   TStdProcProt   = procedure; stdcall;
   TInitProcProt  = procedure (AFunc: TFunc); stdcall;
   TGetHndProcProt  = function : Longword; stdcall;
   TPostProcProt  = procedure (Target: Longword); stdcall;

  TForm1 = class(TForm)
    shpLED: TShape;
    btnOn: TButton;
    btnOff: TButton;
    btnROn: TButton;
    btnROff: TButton;
    Label1: TLabel;
    lblMyHnd: TLabel;
    GroupBox1: TGroupBox;
    GroupBox2: TGroupBox;
    GroupBox3: TGroupBox;
    Label2: TLabel;
    edtTrgt: TEdit;
    btnToggle: TButton;
    procedure btnOnClick(Sender: TObject);
    procedure btnOffClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnROnClick(Sender: TObject);
    procedure btnROffClick(Sender: TObject);
    procedure btnToggleClick(Sender: TObject);
  private
    { Private-Deklarationen }
    fDLLInstance  : THandle;
    fDLLInit   : TInitProcProt;
    fDLLOn  : TStdProcProt;
    fDLLOff : TStdProcProt;
    fDLLGetHandle : TGetHndProcProt;
    fDLLPost : TPostProcProt;
  public
    { Public-Deklarationen }
  end;

    procedure SetLED(State: Integer);  stdcall;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure SetLED(State: Integer);  stdcall;
begin
   if State = 0 then
      Form1.shpLED.Brush.Color   := clGreen
   else
      Form1.shpLED.Brush.Color   := clLime;
end;

procedure TForm1.btnOnClick(Sender: TObject);
begin
   SetLED(1);
end;

procedure TForm1.btnOffClick(Sender: TObject);
begin
   SetLED(0);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
   fDLLInstance   := 0;
   @fDLLInit   := nil;
   @fDLLOn   := nil;
   @fDLLOff   := nil;
   @fDLLGetHandle := nil;
   @fDLLPost := nil;
   fDllInstance := LoadLibrary('cbDLL.dll');
   if fDllInstance <> 0 then
   begin
      @fDLLInit   := GetProcAddress(fDLLInstance, 'Init');
      @fDLLOn   := GetProcAddress(fDLLInstance, 'CallOn');
      @fDLLOff   := GetProcAddress(fDLLInstance, 'CallOff');
      @fDLLGetHandle := GetProcAddress(fDLLInstance, 'GetHandle');
      @fDLLPost := GetProcAddress(fDLLInstance, 'Post');
   end;
   fDLLInit(SetLED);
   lblMyHnd.Caption  := IntToStr(fDLLGetHandle);
end;

procedure TForm1.btnROnClick(Sender: TObject);
begin
   fDLLOn;
end;

procedure TForm1.btnROffClick(Sender: TObject);
begin
   fDLLOff;
end;

procedure TForm1.btnToggleClick(Sender: TObject);
begin
   fDLLPost(StrToInt(edtTrgt.Text));
end;

end.

Damit sehe ich das Thema hiermit für mich als gelöst an.

[js747a]

Wieder mal ein Beispiel das für andere User nicht zu gebrauchen ist.
Die Unit JclSysInfo kennt warscheinlich nur der Ersteller.

[himitsu]

JCL = JEDI Code Library

https://wiki.delphi-jedi.org/wiki/JEDI_Code_Library
https://github.com/project-jedi/jcl
https://sourceforge.net/projects/jcl/
http://dn.embarcadero.com/article/22818
...
delphi jedi

PS: JclSysInfo

[DeddyH]

Erster Treffer bei Google: https://github.com/project-jedi/jcl/...JclSysInfo.pas. Das wäre zielführender gewesen, als alte Threads zu kapern, um dort herumzumeckern.