Ein Objekt um ein selbst definiertes Ereignis erweitern

[scp]

Delphi-Quellcode:

unit UServer; 

interface 

uses classes, Dialogs, windows, extctrls, shellapi; 
                                  
  type TFehlerEvent = procedure(Param1: String) of object; // "of object" evtl. weglassen, je nach dem, ob später eine normale procedure oder eine procedure, die in einem Form deklariert ist, werwendet wird.
  type TServer = class(Tcomponent) 
    private 
      FOnFehler: TFehlerEvent; 
      TWarten : TTimer; 
      function getBoServer : boolean;  
      procedure SetOnOnline(Value: TFehlerEvent); 
      procedure TWartenOnTimer(Sender : TObject); 

    published 
      property OnOnline: TFehlerEvent read FOnFehler write SetonOnline; 

    protected 

    public 
      constructor create; 
      procedure Execute;
  end; 

implementation 

  constructor TServer.create; 
  begin 
    inherited create(nil); // hier noch keine Aktionen
  end;

  procedure TServer.Execute; 
  begin 
    if getBoServer then
      begin
        If Assigned(FOnFehler) then   // Der Aufruf geht dann so von statten
          FOnFehler('text'); 
      end 
    else begin 
      TWarten := TTimer.create(nil); 
      TWarten.interval:=500; 
      Twarten.OnTimer := TwartenOnTimer; 
      TWarten.enabled:=true;  
      ShellExecute(0, 'open', 'Server.exe',  nil, 'C:\buco_bwp\Server', SW_SHOWNORMAL); 
    end; 
  end; 

  function TServer.getBoServer : boolean; 
  begin 
    if FindWindow(nil, 'CAD-Server') = 0 
    then 
       result := false 
    else 
      result := true; 
  end; 

  procedure TServer.SetonOnline(Value: TFehlerEvent); 
  begin 
    FOnFehler = Value;  // Hier wird nur die procedure zugeswiesen 
  end; 

  procedure TServer.TWartenOnTimer(Sender : TObject); 
  begin 
    if getBoServer 
    then begin 
      TWarten.enabled:=false; 
      TWarten.free; 
      If Assigned(FOnFehler) then  // Der Aufruf geht dann so von statten
        FOnFehler('text'); 
    end; 
  end; 

end.

Delphi-Quellcode:

var
  EinServer : TServer;

procedure EinServerOnFehler(param1 : string);
begin
  ShowMessage('hallo');
end;

procedure EinServerStarten;
begin
  EinServer := TServer.Create;
  EinServer.OnOnline := EinServerOnFehler;
  EinServer.Execute;
end;