{: Simple sample datamodule to add, modify or delete a customer. }
unit CustomerTxDmdUnit;

interface
...
type
  TCustomerTxDmd = class(TDataModule, IBcpBasicTx)
    CustomerSrc: TDataSource;
    CustomerQry: TQuery;
    CustomerUpd: TUpdateSQL;
  private
    { Private declarations }
    procedure OpenQry(CustNo: integer);
    procedure ApplyQry(Post: boolean);
    procedure CloseQry;
    function ShowModalForm(FormClass: string): TModalResult;
  public
    { IBcpBasicTx }
    function Add: boolean;
    function Modify(KeyValues: Variant): boolean;
    function Delete(KeyValues: Variant): boolean;
  end;

var
  CustomerTxDmd: TCustomerTxDmd;

implementation

...

initialization
  BcpRegisterModule(TCustomerTxDmd, ciSingleInstance,
    'Customer properties');

end.

procedure BcpRegisterModule(
  aDatamodule: TDatamoduleClass;
  ClassInstancing: TBcpModuleInstancing;
  Description: string);
begin
  { let the vcl raise exceptions with duplicate registrations }
  RegisterClass(aDataModule);
  FModules.AddObject(
    aDataModule.ClassName+'='+Description,
    pointer(ClassInstancing){store the instancing mode});
end;

function TCustomerTxDmd.ShowModalForm(
  FormClass: string): TModalResult;
begin
  Result := 
    TFormClass(FindClass(FormClass)).Create(Self).ShowModal;
end;

  {: Action implementing the IBcpBasicTx's Add method. }
  TBcpBasicTxAddAction = class(TAction)
    ...
  published
    {: Semicolon seperated moduleclassnames which may be used
       to request the interface from if this action is executed. }
    property Module: string read FModule write SetModule;
    {: Allows manual refreshing after a succesfull add. }
    property OnAfterAdd: TNotifyEvent read FOnAfterAdd 
      write SetOnAfterAdd;
  end;

  {: Action implementing the IBcpBasicTx's Modify method. }
  TBcpBasicTxModifyAction = class(TAction)
    ...
  published
    {: Dataset information for keyvalues. }
    property DataSet: TDataSet read FDataSet write SetDataSet;
    {: Allows manual refreshing after a succesfull modify. }
    property OnAfterModify: TNotifyEvent read FOnAfterModify
        write SetOnAfterModify;
    {: Specify the keyfields which are used as identification for
       the record. }
    property KeyFields: string read FKeyFields write SetKeyFields;
  end;

  {: Action implementing the IBcpBasicTx's Delete method. }
  TBcpBasicTxDeleteAction = class(TAction)
    ...
  published
    {: Dataset information for keyvalues. }
    property DataSet: TDataSet read FDataSet write SetDataSet;
    {: Allows manual refreshing after a succesfull delete. }
    property OnAfterDelete: TNotifyEvent read FOnAfterDelete
      write SetOnAfterDelete;
    {: Specify the keyfields which are used as identification 
       for the record. }
    property KeyFields: string read FKeyFields write SetKeyFields;
  end;

  {: BcpBasicBasicTxAction implements a datamodule's interface
     by delegation. In the property Module the datamodule
     classname is specified. Semicolon seperated classnames may
     be entered to allow multiple. This action is enabled if
     any of the specified datamodules is registered
     and implements the IBcpBasicTx interface. }
  TBcpBasicTxAction = class(TAction, IBcpBasicTx)
  private
    FDataSet: TDataSet;
    FModule: string;
    FAvailableModules: TStringList;
    procedure SetDataSet(const Value: TDataSet);
    procedure SetModule(const Value: string);
  protected
    {: Update the list of datamodules, specified by Module, to
       locate the registered datamodules which implement the
       correct interface. }
    procedure UpdateModuleList;
    {: Return the IBcpBasicTx interface of a datamodule. }
    function GetBasicTx: IBcpBasicTx;
    {: Returns true if at least one datamodule is found. }
    function ModuleEnabled: boolean;
    {: This abstract method specifies if a specific interface
       method is enabled. }
    function MethodEnabled: boolean; virtual; abstract;
    {: This list contains all correct datamodules, update this
       list by calling UpdateModuleList. }
    property AvailableModules: TStringList read FAvailableModules;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    procedure Notification(AComponent: TComponent; 
      Operation: TOperation); override;
    {: TAction method to enable targets. }
    function HandlesTarget(Target: TObject): Boolean; override;
    {: TAction method to udpate this action for a target. }
    procedure UpdateTarget(Target: TObject); override;
    {: Property required to delegate the IBcpBasicTx. }
    property BasicTx: IBcpBasicTx read GetBasicTx
      implements IBcpBasicTx;
  published
    {: Semicolon seperated moduleclassnames which may be used
       to request the interface from if this action is executed. }
    property Module: string read FModule write SetModule;
    {: Dataset for descendants to use. }
    property DataSet: TDataSet read FDataSet write SetDataSet;
  end;

procedure TBcpBasicTxAction.UpdateModuleList;
var
  i: integer;
begin
  FAvailableModules.BeginUpdate;
  try
    { Convert the semicolon seperated datamodules into
      seperate strings. }
    FAvailableModules.Text := StringReplace(
      Self.Module, ';', #13, [rfReplaceAll]);
    { Remove the unregistered and unsupported modules from
      the list. }
    i := 0;
    while (i < FAvailableModules.Count) do
    begin
      if (BcpModuleIsRegistered(FAvailableModules[i])) and
         (BcpModuleImplements(FAvailableModules[i], 
            IBcpBasicTx)) then
        Inc(i)
      else
        FAvailableModules.Delete(i);
    end;
  finally
    FAvailableModules.EndUpdate;
  end;
end;

function TBcpBasicTxAction.ModuleEnabled: boolean;
begin
  UpdateModuleList;
  Result := (AvailableModules.Count > 0);
end;

function TBcpBasicTxAction.GetBasicTx: IBcpBasicTx;
var
  idx: integer;
  ModuleName,
  aCaption: string;
begin
  { Default the first datamodule is used. }
  ModuleName := AvailableModules[0];
  if (AvailableModules.Count > 1) then
  begin
    { Transform the action.caption into a caption for the module
      selection }
    aCaption := StringReplace(Self.Caption,'&','',[])+'...';
    { Allow the user to select a datamodule. }
    if ModuleSelect(aCaption, AvailableModules, idx) then
      ModuleName := AvailableModules[idx];
  end;
  { Return the IBcpBasicTx of the datamodule. }
  BcpGetModuleInterface(ModuleName, IBcpBasicTx, Result);
end;

procedure TBcpBasicTxModifyAction.ExecuteTarget(Target: TObject);
begin
  { execute and if succeeded call the aftermodify event }
  if (IBcpBasicTx(Self).Modify(
        DataSet.FieldValues[Self.KeyFields])) and
     (Assigned(FOnAfterModify)) then
    FOnAftermodify(Self);
end;

function BcpModuleIsRegistered(ModuleClassName: string): boolean;
begin
  Result := (GetClass(ModuleClassName) <> nil);
end;

function GetModuleClass(ModuleClassName: string): TDataModuleClass;
begin
  Result := TDataModuleClass(FindClass(ModuleClassName));
end;

function BcpModuleImplements(ModuleClassName: string;
  Guid: TGuid): boolean;
begin
  Result :=
    (BcpModuleIsRegistered(ModuleClassName)) and
    (GetModuleClass(ModuleClassName).GetInterfaceEntry(
       Guid) <> nil);
end;

function BcpGetModuleInterface(ModuleClassName: string;
  Guid: TGuid; out Obj): boolean;
begin
  Result :=
    (BcpModuleIsRegistered(ModuleClassName)) and
    (BcpModuleImplements(ModuleClassName, Guid)) and
    (GetModule(ModuleClassName).GetInterface(Guid, Obj));
end;

function GetModule(ModuleClassName: string): TDataModule;
var
  Instancing: TBcpModuleInstancing;
  i: integer;
begin
  Result := nil;
  Instancing := TBcpModuleInstancing(FModules.Objects[
    FModules.IndexOfName(ModuleClassName)]);
  { If SingleInstance locate an existing module first. }
  if (Instancing = ciSingleInstance) then
  begin
    i := 0;
    while (i < Screen.DataModuleCount) and (Result = nil) do
    begin
      if CompareText(Screen.DataModules[i].ClassName, 
          ModuleClassName) = 0 then
        Result := Screen.DataModules[i]
      else
        Inc(i);
    end;
  end;
  { No instance located or MultiInstance creates a new instance }
  if (Result = nil) then
    Result := (GetModuleClass(ModuleClassName).Create(Application));
end;

function BcpModuleIsRegistered(ModuleClassName: string): boolean;
begin
  Result := (GetClass(ModuleClassName) <> nil);
end;

function BcpModuleImplements(ModuleClassName: string;
  Guid: TGuid): boolean;
begin
  Result :=
    (BcpModuleIsRegistered(ModuleClassName)) and
    (GetModuleClass(ModuleClassName).GetInterfaceEntry(
       Guid) <> nil);
end;

function BcpGetModuleInterface(ModuleClassName: string;
  Guid: TGuid; out Obj): boolean;
begin
  Result :=
    (BcpModuleIsRegistered(ModuleClassName)) and
    (BcpModuleImplements(ModuleClassName, Guid)) and
    (GetModule(ModuleClassName).GetInterface(Guid, Obj));
end;

[English] [welkom] [wie zijn wij] [info] [diensten] [producten] [download] [contact] [verwijzingen]