DLL und Callback-Funktion: Hostprogramm reagiert nicht?

[Bummi]

Nur schnell zusammengestöpselt, ein Rumpf , Fehlerkorrektur erbeten ...


DLL

Delphi-Quellcode:

library Project2;

uses
  SysUtils,
  Classes;

Type

   TCallBackProc=Procedure(info:PChar);
   TDummyThread=Class(TThread)
     Procedure Execute;override;
   End;

{$R *.res}
Var
  SaveExit:Pointer;
  TheCallBackProc:TCallBackProc;

procedure LibExit;far;
begin
     ExitProc := SaveExit;
end;


Procedure InitDLL(CallBackProc:TCallBackProc);
var
 i:Integer;
begin
   TheCallBackProc := CallBackProc;
   for I := 0 to 100 do
     with TDummyThread.Create(false) do FreeOnTerminate := true;
end;

exports
InitDLL index 1;

{ TDummyThread }

procedure TDummyThread.Execute;
begin
  inherited;
  Sleep(Random(2000));
  if Assigned(TheCallBackProc) then TheCallBackProc(PChar(Format('Irnedein Testtext %d',[ThreadID])));
end;

begin
     SaveExit := ExitProc; 
     ExitProc := @LibExit; 
end.

Testprogramm

Delphi-Quellcode:

unit Unit3;

interface

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

type
   TCallBackProc=Procedure(info:PChar);
   TInitDLL=Procedure (p:TCallBackProc);

  TForm3 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private-Deklarationen }
    FH:Thandle;
    FInitDLL:TInitDLL;

  public
    { Public-Deklarationen }
  end;

var
  Form3: TForm3;

implementation
{$R *.dfm}
procedure SyncAddToMemo(const s:String);
begin
  Form3.Memo1.Lines.add(s);
  Application.ProcessMessages;
end;


procedure CallBack(P:PChar);
begin
    TThread.Synchronize(nil,Procedure begin SyncAddToMemo(P) end)
end;



procedure TForm3.Button1Click(Sender: TObject);
begin
  if Assigned(FInitDLL) then FInitDLL(@CallBack);
end;

procedure TForm3.FormCreate(Sender: TObject);
begin
   FH := LoadLibrary(Pchar(ExtractFilePath(Paramstr(0))+'Project2.dll'));
   if FH<>0 then
       FInitDLL := GetProcAddress(FH,'InitDLL');

end;

procedure TForm3.FormDestroy(Sender: TObject);
begin
  if FH<>0 then FreeLibrary(FH);

end;

end.