olefilters.pas

是一个delphi的流程制作软件

//========================== OLE FILTERS =======================================
//
//Implemets some simple Ole message filters
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//==============================================================================


{$INCLUDE OLE.INC}

unit OleFilters;

interface

uses
  Windows, SysUtils, Classes, ActiveX,
  OleInterface, OleDlgs;

//=== Ole Message Filters ======================================================

type
  TInComingCallEvent = procedure (Sender : TObject; CallType : TCallType; Task : hTask; TickCount : integer; var Info : TInterfaceInfo; var Result : TServerCall) of Object;
  TRetryRejectedCallEvent = procedure (Sender : TObject; Task : hTask; TickCount : integer; Reject : TServerCall; var Result : integer) of Object;
  TMsgPendingEvent = procedure (Sender : TObject; Task : hTask; TickCount : integer; Pending : TPendingType; var Result : TPendingMsg) of Object;

  TCustomMsgFilter = class (TBaseMessageFilter)
  private
    FInComingCall : TInComingCallEvent;
    FRetryRejectedCall : TRetryRejectedCallEvent;
    FMsgPending : TMsgPendingEvent;
    FDialog : TOleBusyDialog;
  protected
    procedure HandleInComingCall (CallType : TCallType; Task : hTask; TickCount : integer; var Info : TInterfaceInfo; var Result : TServerCall); override;
    procedure RetryRejectedCall (Task : hTask; TickCount : integer; Reject : TServerCall; var Result : integer); override;
    procedure MessagePending (Task : hTask; TickCount : integer; Pending : TPendingType; var Result : TPendingMsg); override;
    procedure Notification (Component : TComponent; Operation : TOperation); override;
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
    procedure Register; virtual;
    procedure Revoke; virtual;
    property OnHandleInComingCall : TInComingCallEvent read FInComingCall write FInComingCall;
    property OnRetryRejectedCall : TRetryRejectedCallEvent read FRetryRejectedCall write FRetryRejectedCall;
    property OnMessagePending : TMsgPendingEvent read FMsgPending write FMsgPending;
    property BusyDialog : TOleBusyDialog read FDialog write FDialog;
  end;

  TClientMsgFilter = class (TCustomMsgFilter)
  published
    property BusyDialog;
    property OnRetryRejectedCall;
    property OnMessagePending;
  end;

  TServerMsgFilter = class (TCustomMsgFilter)
  published
    property OnHandleInComingCall;
  end;

  TMsgFilter = class (TCustomMsgFilter)
  published
    property BusyDialog;
    property OnHandleInComingCall;
    property OnRetryRejectedCall;
    property OnMessagePending;
  end;

implementation

//=== CUSTOM FILTER ============================================================

constructor TCustomMsgFilter.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  Register
end;

destructor TCustomMsgFilter.Destroy;
begin
  Revoke;
  inherited Destroy
end;

procedure TCustomMsgFilter.Register;
var
  Dump : IMessageFilter;
begin
  CoRegisterMessageFilter (Self, Dump)
end;

procedure TCustomMsgFilter.Revoke;
var
  Dump : IMessageFilter;
begin
  CoRegisterMessageFilter (nil, Dump)
end;

procedure TCustomMsgFilter.HandleInComingCall (CallType : TCallType; Task : hTask; TickCount : integer; var Info : TInterfaceInfo; var Result : TServerCall);
begin
  Result := scIsHandled;
  if Assigned (FInComingCall) then
    FInComingCall (Self, CallType, Task, TickCount, Info, Result)
end;

procedure TCustomMsgFilter.RetryRejectedCall (Task : hTask; TickCount : integer; Reject : TServerCall; var Result : integer);
begin
  if Reject = scRejected then
    Result := -1
  else
    Result := 0;
// by preference use the event
  if Assigned (FRetryRejectedCall) then
    FRetryRejectedCall (Self, Task, TickCount, Reject, Result)
  else
// if a busy dialog has been linked then use it as a simple default process
// unless its a reject call
    if (Reject <> scRejected) and Assigned (FDialog) then
      Result := FDialog.RetryRejectedCall (Task, TickCount)
end;

procedure TCustomMsgFilter.MessagePending (Task : hTask; TickCount : integer; Pending : TPendingType; var Result : TPendingMsg);
begin
  if Assigned (FMsgPending) then
    FMsgPending (Self, Task, TickCount, Pending, Result)
end;

procedure TCustomMsgFilter.Notification (Component : TComponent; Operation : TOperation);
begin
  if (Operation = opRemove) and (Component = FDialog) then
    FDialog := nil
end;

end.