appevnts.pas

这是不可多得的源代码

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{                                                       }
{  Copyright (c) 1995-2001 Borland Software Corporation }
{                                                       }
{*******************************************************}

unit AppEvnts;

interface

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

type
  TCustomApplicationEvents = class(TComponent)
  private
    FOnActionExecute: TActionEvent;
    FOnActionUpdate: TActionEvent;
    FOnException: TExceptionEvent;
    FOnMessage: TMessageEvent;
    FOnHelp: THelpEvent;
    FOnHint: TNotifyEvent;
    FOnIdle: TIdleEvent;
    FOnDeactivate: TNotifyEvent;
    FOnActivate: TNotifyEvent;
    FOnMinimize: TNotifyEvent;
    FOnRestore: TNotifyEvent;
    FOnShortCut: TShortCutEvent;
    FOnShowHint: TShowHintEvent;
    FOnSettingChange: TSettingChangeEvent;
    FOnModalBegin: TNotifyEvent;
    FOnModalEnd: TNotifyEvent;
    procedure DoActionExecute(Action: TBasicAction; var Handled: Boolean);
    procedure DoActionUpdate(Action: TBasicAction; var Handled: Boolean);
    procedure DoActivate(Sender: TObject);
    procedure DoDeactivate(Sender: TObject);
    procedure DoException(Sender: TObject; E: Exception);
    procedure DoIdle(Sender: TObject; var Done: Boolean);
    function DoHelp(Command: Word; Data: Longint; var CallHelp: Boolean): Boolean;
    procedure DoHint(Sender: TObject);
    procedure DoMessage(var Msg: TMsg; var Handled: Boolean);
    procedure DoMinimize(Sender: TObject);
    procedure DoRestore(Sender: TObject);
    procedure DoShowHint(var HintStr: string; var CanShow: Boolean;
      var HintInfo: THintInfo);
    procedure DoShortcut(var Msg: TWMKey; var Handled: Boolean);
    procedure DoSettingChange(Sender: TObject; Flag: Integer; const Section: string; var Result: Longint);
    procedure DoModalBegin(Sender: TObject);
    procedure DoModalEnd(Sender: TObject);
  protected
    property OnActionExecute: TActionEvent read FOnActionExecute write FOnActionExecute;
    property OnActionUpdate: TActionEvent read FOnActionUpdate write FOnActionUpdate;
    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
    property OnException: TExceptionEvent read FOnException write FOnException;
    property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
    property OnHelp: THelpEvent read FOnHelp write FOnHelp;
    property OnHint: TNotifyEvent read FOnHint write FOnHint;
    property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
    property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
    property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
    property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;
    property OnShortCut: TShortCutEvent read FOnShortCut write FOnShortCut;
    property OnSettingChange: TSettingChangeEvent read FOnSettingChange write FOnSettingChange;
    property OnModalBegin: TNotifyEvent read FOnModalBegin write FOnModalBegin;
    property OnModalEnd: TNotifyEvent read FOnModalEnd write FOnModalEnd;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Activate;
    procedure CancelDispatch;
  end;

  TApplicationEvents = class(TCustomApplicationEvents)
  published
    property OnActionExecute;
    property OnActionUpdate;
    property OnActivate;
    property OnDeactivate;
    property OnException;
    property OnIdle;
    property OnHelp;
    property OnHint;
    property OnMessage;
    property OnMinimize;
    property OnRestore;
    property OnShowHint;
    property OnShortCut;
    property OnSettingChange;
  end;

implementation

uses Contnrs, Consts, StdActns, Controls;

type
  TMultiCaster = class(TComponent)
  private
    FAppEvents: TComponentList;
    FCacheAppEvent: TCustomApplicationEvents;
    FCancelDispatching: Boolean;
    FDispatching: Integer;
    procedure BeginDispatch;
    procedure EndDispatch;
    procedure DoActionExecute(Action: TBasicAction; var Handled: Boolean);
    procedure DoActionUpdate(Action: TBasicAction; var Handled: Boolean);
    procedure DoActivate(Sender: TObject);
    procedure DoDeactivate(Sender: TObject);
    procedure DoException(Sender: TObject; E: Exception);
    procedure DoIdle(Sender: TObject; var Done: Boolean);
    function DoHelp(Command: Word; Data: Longint; var CallHelp: Boolean): Boolean;
    procedure DoHint(Sender: TObject);
    procedure DoMessage(var Msg: TMsg; var Handled: Boolean);
    procedure DoMinimize(Sender: TObject);
    procedure DoRestore(Sender: TObject);
    procedure DoShowHint(var HintStr: string; var CanShow: Boolean;
      var HintInfo: THintInfo);
    procedure DoShortcut(var Msg: TWMKey; var Handled: Boolean);
    procedure DoSettingChange(Sender: TObject; Flag: Integer; const Section: string; var Result: Longint);
    procedure DoModalBegin(Sender: TObject);
    procedure DoModalEnd(Sender: TObject);
    function GetCount: Integer;
    function GetAppEvents(Index: Integer): TCustomApplicationEvents;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Activate(AppEvent: TCustomApplicationEvents);
    procedure AddAppEvent(AppEvent: TCustomApplicationEvents);
    procedure CancelDispatch;
    function CheckDispatching(AppEvents: TCustomApplicationEvents): Boolean;

    property AppEvents[Index: Integer]: TCustomApplicationEvents
      read GetAppEvents; default;
    property Count: Integer read GetCount;
  end;

var
  MultiCaster: TMultiCaster = nil;

{ TCustomApplicationEvents }

procedure TCustomApplicationEvents.Activate;
begin
  if Assigned(MultiCaster) then
    MultiCaster.Activate(Self);
end;

procedure TCustomApplicationEvents.CancelDispatch;
begin
  if Assigned(MultiCaster) then
    MultiCaster.CancelDispatch;
end;

constructor TCustomApplicationEvents.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if Assigned(MultiCaster) then
    MultiCaster.AddAppEvent(Self);
end;

procedure TCustomApplicationEvents.DoActionExecute(Action: TBasicAction;
  var Handled: Boolean);
begin
  if Assigned(FOnActionExecute) then FOnActionExecute(Action, Handled);
end;

procedure TCustomApplicationEvents.DoActionUpdate(Action: TBasicAction;
  var Handled: Boolean);
begin
  if Assigned(FOnActionUpdate) then FOnActionUpdate(Action, Handled);
end;

procedure TCustomApplicationEvents.DoActivate(Sender: TObject);
begin
  if Assigned(FOnActivate) then FOnActivate(Sender);
end;

procedure TCustomApplicationEvents.DoDeactivate(Sender: TObject);
begin
  if Assigned(FOnDeactivate) then FOnDeactivate(Sender);
end;

procedure TCustomApplicationEvents.DoException(Sender: TObject;
  E: Exception);
begin
  if not (E is EAbort) and Assigned(FOnException) then
    FOnException(Sender, E)
end;

function TCustomApplicationEvents.DoHelp(Command: Word; Data: Integer;
  var CallHelp: Boolean): Boolean;
begin
  if Assigned(FOnHelp) then
    Result := FOnHelp(Command, Data, CallHelp)
  else Result := False;
end;

procedure TCustomApplicationEvents.DoHint(Sender: TObject);
begin
  if Assigned(FOnHint) then
    FOnHint(Sender)
  else
    with THintAction.Create(Self) do
    try
      Hint := Application.Hint;
      Execute;
    finally
      Free;
    end;
end;

procedure TCustomApplicationEvents.DoIdle(Sender: TObject; var Done: Boolean);
begin
  if Assigned(FOnIdle) then FOnIdle(Sender, Done);
end;

procedure TCustomApplicationEvents.DoMessage(var Msg: TMsg; var Handled: Boolean);
begin
  if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
end;

procedure TCustomApplicationEvents.DoMinimize(Sender: TObject);
begin
  if Assigned(FOnMinimize) then FOnMinimize(Sender);
end;

procedure TCustomApplicationEvents.DoRestore(Sender: TObject);
begin
  if Assigned(FOnRestore) then FOnRestore(Sender);
end;

procedure TCustomApplicationEvents.DoShortcut(var Msg: TWMKey;
  var Handled: Boolean);
begin
  if Assigned(FOnShortcut) then FOnShortcut(Msg, Handled);
end;

procedure TCustomApplicationEvents.DoShowHint(var HintStr: string;
  var CanShow: Boolean; var HintInfo: THintInfo);
begin
  if Assigned(FOnShowHint) then FOnShowHint(HintStr, CanShow, HintInfo);
end;

procedure TCustomApplicationEvents.DoSettingChange(Sender: TObject; Flag: Integer;
  const Section: string; var Result: Longint);
begin
  if Assigned(FOnSettingChange) then FOnSettingChange(Sender, Flag, Section, Result);
end;

procedure TCustomApplicationEvents.DoModalBegin(Sender: TObject);
begin
  if Assigned(FOnModalBegin) then FOnModalBegin(Sender);
end;

procedure TCustomApplicationEvents.DoModalEnd(Sender: TObject);
begin
  if Assigned(FOnModalEnd) then FOnModalEnd(Sender);
end;

{ TMultiCaster }

procedure TMultiCaster.Activate(AppEvent: TCustomApplicationEvents);
begin
  if CheckDispatching(AppEvent) and
    (FAppEvents.IndexOf(AppEvent) < FAppEvents.Count - 1) then
  begin
    FAppEvents.Remove(AppEvent);
    FAppEvents.Add(AppEvent);
  end;
end;

procedure TMultiCaster.AddAppEvent(AppEvent: TCustomApplicationEvents);
begin
  if FAppEvents.IndexOf(AppEvent) = -1 then
    FAppEvents.Add(AppEvent);
end;

procedure TMultiCaster.BeginDispatch;
begin
  Inc(FDispatching);
end;

procedure TMultiCaster.CancelDispatch;
begin
  FCancelDispatching := True;
end;

function TMultiCaster.CheckDispatching(AppEvents: TCustomApplicationEvents): Boolean;
begin
  Result := FDispatching = 0;
  if not Result then
    FCacheAppEvent := AppEvents;
end;

constructor TMultiCaster.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAppEvents := TComponentList.Create(False);
  with Application do
  begin
    OnActionExecute := DoActionExecute;
    OnActionUpdate := DoActionUpdate;
    OnActivate := DoActivate;
    OnDeactivate := DoDeactivate;
    OnException := DoException;
    OnHelp := DoHelp;
    OnHint := DoHint;
    OnIdle := DoIdle;
    OnMessage := DoMessage;
    OnMinimize := DoMinimize;
    OnRestore := DoRestore;
    OnShowHint := DoShowHint;
    OnShortCut := DoShortcut;
    OnSettingChange := DoSettingChange;
    OnModalBegin := DoModalBegin;
    OnModalEnd := DoModalEnd;
  end;
end;

destructor TMultiCaster.Destroy;
begin
  MultiCaster := nil;