dsnunit.pas

DELPHI编写的商场收银POS机源代码

unit DsnUnit;

// Runtime Design System Version 2.x   June/08/1998
// Copyright(c) 1998 Kazuhiro Sasaki.

interface

uses
  Windows, Messages, SysUtils, {COMMCTRL,}Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, TypInfo, ExtCtrls, Buttons, Grids,
  Clipbrd, Menus, COMCTRLS, DsnShape, DsnHandle, DsnList, DsnProp,
  DsnPanel, DsnMes, DsnLgMes, DsnAgent, DsnFunc;


type

  TResizeMessage = record
    Msg: Cardinal;
    SLeft:Smallint;
    STop:Smallint;
    SWidth:Smallint;
    SHeight:Smallint;
    Result: Longint;
  end;

  TDsnStage = class;
  TDsnCtrl = class;
  TDsnRegister = class;

  TDsnList = class(TList)
  end;

  TDsnPartner = class(TComponent)
  private
    FDsnRegister: TDsnRegister;
  protected
    FDesigning: Boolean;
    procedure SetDsnRegister(Value:TDsnRegister);
    procedure SetDesigning(Value:Boolean);virtual;
    procedure CreateTargetList;
    procedure CreateMoveShape;
    function CheckCanSelect(Control: TControl): Boolean;
    function GetDsnList:TDsnList;
    function GetTargetList:TTargetList;
  public
    constructor Create(AOwner: TComponent); override;
    property DsnRegister: TDsnRegister read FDsnRegister write SetDsnRegister;
  end;

  TDsnRegister = class(TComponent)
  private
    FDesigning:Boolean;
    FDsnPanel:TCustomCmpPlt;
    FDsnStage:TDsnStage;
    FDsnInspector:TCustomInspector;
    FArrowButton:TArrowButton;
    FProps: TMultiProps;
    FContextMenu :TPopupMenu;
  protected
    FDsnCtrlList: TDsnList;
    DsnNotifies: TList;
    DsnPartners: TList;
//    FLastTarget: TComponent;
    FTargetList: TTargetList;
    FParentCtrl: TWinControl;
    FX, FY: Integer;
    CutSizeX:Integer;
    CutSizeY:Integer;
    Color:TColor;
    PenWidth:Integer;
    FDsnControl:TComponent;
    FHandler: TMultiHandler;
    FShape: TMultiShape;
    procedure CreateSubClass;
    procedure DestroySubClass;
    procedure SetDsnStage(Value:TDsnStage);
    procedure SetDsnPanel(Value:TCustomCmpPlt);
    procedure SetDsnInspector(Value:TCustomInspector);
    procedure SetArrowButton(Value:TArrowButton);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure AlertClientDeath;virtual;
    procedure AlertTargetDeath;virtual;
    procedure SetDesigning(Value:Boolean);virtual;
    procedure CreateHandler;virtual;
    procedure CreateCopyShape;virtual;
    procedure CreateMoveShape;virtual;
    function CreateSubCtrl(AParent:TWinControl):TDsnCtrl;virtual;
    function CreateList:TTargetList;virtual;
    function CreateDsnList:TDsnList;virtual;
    function CreateProps:TMultiProps;
    procedure Cutting(var X, Y: Integer);
    procedure MouseDown(Client:TWinControl; Target:TComponent; MousePoint:TPoint; Shift: TShiftState);virtual;
    procedure MoseMove(Client:TWinControl; MousePoint:TPoint; Shift: TShiftState);virtual;
    procedure MoseUp(Client:TWinControl; MousePoint:TPoint; Shift: TShiftState);virtual;
    procedure MouseDownCreate(Client:TWinControl; Target:TComponent; MousePoint:TPoint; Shift: TShiftState);virtual;
    procedure MouseMoveCreate(Client:TWinControl; MousePoint:TPoint; Shift: TShiftState);virtual;
    procedure MouseUpCreate(Client:TWinControl; MousePoint:TPoint; Shift: TShiftState);virtual;
    procedure MouseDownMove(Client:TWinControl; Target:TComponent; MousePoint:TPoint; Shift: TShiftState);virtual;
    procedure MouseMoveMove(Client:TWinControl; MousePoint:TPoint; Shift: TShiftState);virtual;
    procedure MouseUpMove(Client:TWinControl; MousePoint:TPoint; Shift: TShiftState);virtual;
    procedure DbClick(Target:TControl; var Message: TWMMouse);virtual;
    procedure CallPopupMenu(Client:TWinControl; Target:TControl; XPos,YPos: Integer);virtual;
    procedure RButtonDown(Client:TWinControl; Target:TControl; XPos,YPos: Integer);virtual;
    function CanCopy:Boolean;virtual;
    function CanPaste:Boolean;virtual;
    function PasteZero:TWinControl;virtual;
    procedure Cut;virtual;
    procedure Copy;virtual;
    procedure Paste;virtual;
    procedure Delete;virtual;
    procedure ComponentsProcClipbrd(Component:TComponent);
    procedure CopyPaste(Ctrl:TControl;aParent:TWinControl);
    procedure ComponentsProc(Component:TComponent);virtual;
    procedure GiveName(Component: TComponent);virtual;
    procedure Resized(Control:TControl;var Message: TResizeMessage);virtual;
    procedure Moved(DeltaX,DeltaY: Integer);virtual;
    procedure Selected(Control:TControl;var Message: TMessage);virtual;
    procedure SelectByInspect(Control:TControl);
    procedure SetSubClass(AParent: TWinControl);
    procedure CreateContextMenu;virtual;
    procedure MenuMethod(Sender:TObject);virtual;
    procedure CheckName(Reader:TReader; Component:TComponent; var Name:String);
    procedure SortForDelete(List: TList);
    //procedure AddReceiveTargets(List: TReceiveTargets); virtual;
    function CheckCanSelect(Control: TControl): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Designing:Boolean read FDesigning write SetDesigning;
    function SameParent:Boolean;
    procedure ClearSelect;
    procedure AddPartners(Partner: TDsnPartner); virtual;
    procedure RemovePartners(Partner: TDsnPartner); virtual;
    procedure AddNotifies(List: TReceiveTargets); virtual;
  published
    property DsnStage:TDsnStage read FDsnStage write SetDsnStage;
    property DsnPanel:TCustomCmpPlt read FDsnPanel write SetDsnPanel;
    property DsnInspector: TCustomInspector read FDsnInspector write SetDsnInspector;
    //Someday, DsnInspector property will be abolished  when TCustomInspector become a subclass of TDsnPartner.
    property ArrowButton: TArrowButton read FArrowButton write SetArrowButton;
    //Someday, ArrowButton property will be abolished when DsnInspector property is abolished.
  end;

  TRubberband = class(TPersistent)
  private
    FColor:TColor;
    FPenWidth:Integer;
    FMoveWidth:Integer;
    FMoveHeight:Integer;
  published
    property Color:TColor read FColor write FColor;
    property PenWidth:Integer read FPenWidth write FPenWidth;
    property MoveWidth:Integer read FMoveWidth write FMoveWidth;
    property MoveHeight:Integer read FMoveHeight write FMoveHeight;
  end;

  TSelectAccept = set of (saCreate, saMove);
  TSelectQuery = procedure
                    (Sender:TObject;Component:TComponent;
                           var CanSelect:TSelectAccept) of Object;
  TMoveQuery = procedure
                    (Sender:TObject;Component:TComponent;
                           var CanMove:Boolean) of Object;
  TCoverAccept = (caAllAccept, caNoAccept, caChildrenAccept);
  TCoverQuery = procedure
                    (Sender:TObject;Component:TComponent;
                           var CanCover:TCoverAccept) of Object;
  TControlCreate = procedure
                    (Sender:TObject;Component:TComponent)
                                                      of Object;
  TCallCompoEditor = procedure
                    (Sender:TObject;Component:TComponent)
                                                      of Object;
  TDsnStage = class(TPanel)
  private
    FDsnRegister: TDsnRegister;
    FSelfProps:TStrings;
    FOutProps:TStrings;
    FOnDeleteQuery:TDeleteQuery;
    FOnCoverQuery:TCoverQuery;
    FOnSelectQuery:TSelectQuery;
    FOnMoveQuery:TMoveQuery;
    FOnControlCreate:TControlCreate;
    FOnControlLoaded:TControlCreate;
    FOnControlLoading:TControlCreate;
    FOnCoverDblClick:TCallCompoEditor;
    FOnMenuClick:TCallPropEditor;
    FOnPopup:TNotifyEvent;
    FRubberband:TRubberband;
    FCoverMenu:TPopupMenu;
    FFixPosition:Boolean;
    FFixSize:Boolean;
    FDesigning:Boolean;
  protected
    procedure SetSelfProps(Value: TStrings);
    procedure SetOutProps(Value: TStrings);
    procedure ComponentsProc(Component:TComponent);
    procedure CheckName(Reader:TReader; Component:TComponent; var Name:String); virtual;
    procedure WriteComponents(Stream:TStream;Control:TControl); virtual;
    procedure ReadComponents(Stream:TStream); virtual;
    procedure ReadError(Reader: TReader; const Message: string; var Handled: Boolean); virtual;
    procedure FindMethod(Reader: TReader; const MethodName: string;
               var Address: Pointer; var Error: Boolean); virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure WMKeyUp(var Message: TWmKeyUp); message WM_KEYUP;
    procedure ClientDeth(var Message:TMessage); message AG_DESTROY;
    procedure PropertyChanged(var Message:TMessage); message CI_SETPROPERTY;
    procedure ControlCreated(var Message:TMessage); message DR_CREATED;
    procedure ControlLoaded(var Message: TMessage); message DS_LOADED;
    function GetControls(Index:Integer):TControl;
    function GetCanCopy:Boolean;
    function GetCanPaste:Boolean;
    procedure KeyPress(var Key: Char); override;
    procedure SetDesignig(Value:Boolean); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure SaveToFile(FileName:String);
    procedure SaveToStream(Stream:TStream);
    procedure LoadFromFile(FileName:String);
    procedure LoadFromStream(Stream:TStream);
    procedure Cut;
    procedure Copy;
    procedure Paste;
    procedure UpdateControl;
    function TargetsCount:Integer;
    procedure Delete;
    property Targets[Index:Integer]:TControl read GetControls;
    property CanCopy: Boolean read GetCanCopy;
    property CanPaste: Boolean read GetCanPaste;
    property Designing: Boolean read FDesigning;
  published
    property SelfProps:TStrings read FSelfProps write SetSelfProps;
    property OutProps:TStrings read FOutProps write SetOutProps;
    property Rubberband:TRubberband read FRubberband write FRubberband;
    property CoverMenu:TPopupMenu read FCoverMenu write FCoverMenu;
    property FixPosition:Boolean read FFixPosition write FFixPosition;
    property FixSize:Boolean read FFixSize write FFixSize;
    property OnDeleteQuery:TDeleteQuery read FOnDeleteQuery write FOnDeleteQuery;
    property OnCoverQuery:TCoverQuery read FOnCoverQuery write FOnCoverQuery;
    property OnSelectQuery:TSelectQuery read FOnSelectQuery write FOnSelectQuery;
    property OnMoveQuery:TMoveQuery read FOnMoveQuery write FOnMoveQuery;
    property OnControlCreate:TControlCreate read FOnControlCreate write FOnControlCreate;
    property OnControlLoading:TControlCreate read FOnControlLoading write FOnControlLoading;
    property OnControlLoaded:TControlCreate read FOnControlLoaded write FOnControlLoaded;
    property OnCoverDblClick:TCallCompoEditor read FOnCoverDblClick write FOnCoverDblClick;
    property OnMenuClick:TCallPropEditor read FOnMenuClick write FOnMenuClick;
    property OnPopup:TNotifyEvent read FOnPopup write FOnPopup;
  end;

  TDsnSwitch = class(TSpeedButton)
  private
    FDsnRegister:TDsnRegister;
    FDsnMessageFlg:Boolean;
    FDsnMessage:String;
  protected
    procedure SetDsnRegister(Value:TDsnRegister);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Loaded; override;
    procedure Click; override;
    procedure DesignOn;
    procedure DesignOff;
  published
    property DsnRegister:TDsnRegister read FDsnRegister write SetDsnRegister;
    property DsnMessageFlg:Boolean read FDsnMessageFlg write FDsnMessageFlg;
    property DsnMessage:String read FDsnMessage write FDsnMessage;
  end;

  TDsnCtrl = class(TClientAgent)
  private
    FDsnRegister: TDsnRegister;
    ClientDeath: Boolean;
  protected
    FMousePoint: TPoint;
    procedure TakeInstance;override;
    procedure ReleaseInstance;override;
    procedure ClientWndProc(var Message: TMessage);override;
    procedure ClientMouseDown(var Message: TWMMouse);virtual;
    procedure ClientMouseMove(var Message: TWMMouse);virtual;
    procedure ClientMouseUp(var Message: TWMMouse);virtual;
    procedure ClientPaint(var Message: TWMPaint);virtual;
    procedure ClientCaptureChanged(var Message: TMessage);override;
    procedure ClientPreResize(var Message: TMessage);virtual;
    procedure ClientResize(var Message: TResizeMessage);virtual;
    procedure ClientSelect(var Message: TMessage);virtual;
    procedure ClientSelectByInspect(var Message: TMessage);virtual;
    procedure ClientSetFocus(var Message: TMessage);virtual;
    procedure ClientDbClick(var Message: TWMMouse);virtual;
    procedure ClientContextMenu(var Message: TWMMouse);virtual;
    procedure ClientHandleChange(var Message: TMessage);virtual;
  public
    constructor CreateInstance(AClient: TWinControl); override;
    property DsnRegister: TDsnRegister read FDsnRegister;
  end;

  TDsnSwich = class(TDsnSwitch)
  end;
  
  procedure Register;
  function CompareParent(Item1, Item2: Pointer): Integer;


implementation

uses {for Register Method}
  DsnSpctr, DsnSubDp, DsnSubRS, DsnSubCl, DsnSelect;

const
  DsnSwc_GrpIdx = 2302;

type

  TDsnMenuItem = class(TMenuItem)
  private
    PropName:String;
    Value:String;
  end;

var
  UDsnStage: TDsnStage;

{ TDsnRegister }
constructor TDsnRegister.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDesigning:= False;
end;

destructor TDsnRegister.Destroy;
var
  i: integer;
begin
  if Assigned(FHandler) then
  begin
    FHandler.Free;
    FHandler:= nil;
  end;

  if Assigned(FDsnCtrlList) then
  begin
    for i:= 0 to FDsnCtrlList.Count -1 do
    begin
      TDsnCtrl(FDsnCtrlList[i]).ClientDeath:= True;
      TDsnCtrl(FDsnCtrlList[i]).Free;
    end;
    FDsnCtrlList.Free;
  end;

  if Assigned(FTargetList) then
  begin
    FTargetList.Clear;
    FTargetList.Free;
  end;

  if DsnNotifies <> nil then
    DsnNotifies.Free;

  if DsnPartners <> nil then
    DsnPartners.Free; 

  inherited;
end;

procedure TDsnRegister.Notification(AComponent: TComponent; Operation: TOperation);
var
  i,n:integer;
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
  begin
    if AComponent = FDsnStage then
    begin
      FDsnStage := nil;
    end;

    if AComponent = FDsnInspector then FDsnInspector := nil;
    if AComponent = FDsnPanel then FDsnPanel := nil;
    if AComponent = FArrowButton then FArrowButton := nil;

    if Assigned(FDsnCtrlList) then
      for i:= FDsnCtrlList.Count -1 downto 0 do
        if AComponent = TDsnCtrl(FDsnCtrlList[i]).Client then
        begin
          AlertClientDeath;
          TDsnCtrl(FDsnCtrlList[i]).ClientDeath:= True;
          // Free DsnCtrl in TDsnStage.ClientDeth
          FDsnCtrlList.Delete(i);
        end;

    if Assigned(FTargetList) then
    begin
      n:= FTargetList.IndexOf(AComponent);
      if n > -1 then
      begin
        FTargetList.ItemDeath(n);
        AlertTargetDeath;
        FTargetList.Delete(n);
        if not SameParent then
          FTargetList.Clear;
        FTargetList.SetPosition;
      end;
    end;
  end;
end;

procedure TDsnRegister.AlertClientDeath;
begin
end;

procedure TDsnRegister.AlertTargetDeath;
begin
end;

procedure TDsnRegister.SetDsnStage(Value:TDsnStage);
begin
  if Assigned(Value) then
  begin
    FDsnStage:=Value;
    FDsnStage.FreeNotification(Self);
    CutSizeX:= FDsnStage.FRubberband.MoveWidth;
    CutSizeY:= FDsnStage.FRubberband.MoveHeight;
    Color:= FDsnStage.FRubberband.Color;
    PenWidth:= FDsnStage.FRubberband.PenWidth;
    FDsnStage.FDsnRegister:= Self;
  end
  else
    FDsnStage:=nil;
end;

procedure TDsnRegister.SetDsnPanel(Value:TCustomCmpPlt);
begin
  if Assigned(Value) then
  begin
    FDsnPanel:=Value;
    FDsnPanel.FreeNotification(Self);
  end
  else
    FDsnPanel:=nil;
end;

procedure TDsnRegister.SetArrowButton(Value:TArrowButton);
begin
  if Assigned(Value) then
  begin
    FArrowButton:=Value;
    FArrowButton.FreeNotification(Self);
  end
  else
    FArrowButton:=nil;
end;

procedure TDsnRegister.SetDsnInspector(Value:TCustomInspector);
begin
  if Assigned(Value) then
  begin
    FDsnInspector:=Value;
    FDsnInspector.FreeNotification(Self);
  end
  else
    FDsnInspector:=nil;
end;

procedure TDsnRegister.SetDesigning(Value:Boolean);
var
 Item: TMenuItem;
 i:integer;
begin
  if Value = FDesigning then
    Exit;

  FDesigning:= Value;

  if Assigned(DsnPartners) then
    for i := 0 to DsnPartners.Count -1 do
      TDsnPartner(DsnPartners[i]).SetDesigning(FDesigning);

  if FDesigning then
  begin
    if Assigned(FDsnStage) then
    begin
      FDsnStage.FDsnRegister:= Self;
      CreateSubClass;
      CreateContextMenu;
      FDsnStage.SetFocus;
      FDsnStage.FDesigning:= True;
      FDsnStage.SetDesigning(FDesigning);
    end;

    if Assigned(FDsnPanel) then
    begin
      if Assigned(FArrowButton) then
      begin
        FDsnPanel.SetArrowButton(FArrowButton);
        FArrowButton.SetDsnPanel(FDsnPanel);
      end;
      FDsnPanel.Designing:= True;
    end;
    if Assigned(FDsnInspector) then
    begin
      FDsnInspector.Designing:= True;
      if Assigned(FDsnStage) then
        FDsnInspector.StageHandle:= FDsnStage.Handle;
    end;
  end
  else
  begin
    if Assigned(FDsnStage) then
    begin
      DestroySubClass;
      FDsnStage.FDesigning:= False;
      FDsnStage.SetDesignig(FDesigning);
    end;
    if Assigned(FContextMenu) then
    begin
      for i:= 0 to FContextMenu.Tag -1 do
      begin
        Item:= FContextMenu.Items[0];
        FContextMenu.Items.Remove(Item);
        FDsnStage.CoverMenu.Items.Add(Item);
      end;
      FContextMenu.Free;
      FContextMenu:= nil;
    end;
    if Assigned(FDsnPanel) then
    begin
      FDsnPanel.Designing:= False;
      FDsnPanel.SetTemplate(nil);
    end;
    if Assigned(FDsnInspector) then
      FDsnInspector.Designing:= False;
    if Assigned(FProps) then
    begin
      FProps.Free;
      FProps:= nil;
    end;
    if Assigned(FHandler) then
    begin
      FHandler.Free;
      FHandler:= nil;
    end;
    if Assigned(FTargetList) then
    begin
      FTargetList.Free;
      FTargetList:= nil;
    end;
  end;
end;

procedure TDsnRegister.SetSubClass(AParent: TWinControl);
var
  DsnCtrl: TDsnCtrl;
  procedure ProcA(AAParent:TWinControl);
  var
    List:TChildList;
    i:integer;
    CanCover: TCoverAccept;
    procedure ProcB(AHandle:Integer;Agent:TDsnCtrl);
    var
      BList:TChildList;
      j:integer;