dsnunit.pas

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

  i: integer;
begin
  Result:= TTargetList.Create;

  if Assigned(FHandler) then
    FHandler.Free;
  if Assigned(FProps) then
    FProps.Free;

  if Assigned(FDsnStage) then
  begin
    CreateHandler;
    FHandler.Color:= Color;
    FHandler.PenWidth:= PenWidth;
    FHandler.CutSizeX:= CutSizeX;
    FHandler.CutSizeY:= CutSizeY;
    Result.SelectNotification(FHandler);
  end;

  if Assigned(FDsnInspector) then
  begin
    FProps:= CreateProps;
    Result.SelectNotification(FProps);
    FProps.SetInspector(FDsnInspector);
    InspectList:= TStringList.Create;
    CaptionList:= TStringList.Create;
    FDsnInspector.GetPropLists(InspectList,CaptionList);
    FProps.SetInspectList(InspectList);
    FProps.SetCaptionList(CaptionList);
    FProps.SetOutList(FDsnInspector.GetOutProps);
    InspectList.Free;
    CaptionList.Free;
  end;

  if DsnNotifies <> nil then
  begin
    for i := 0 to DsnNotifies.Count -1 do
    begin
      Result.SelectNotification(TReceiveTargets(DsnNotifies[i]));
    end;
  end;
end;

procedure TDsnRegister.ComponentsProc(Component:TComponent);
begin
  FDsnControl:=Component;
end;

procedure TDsnRegister.CopyPaste(Ctrl:TControl;aParent:TWinControl);
var
  MemoryStream:TMemoryStream;
  Writer:TWriter;
  Reader:TReader;
  S:String;
begin
  S:= Ctrl.Name;
  Ctrl.Name:='';
  //Copy
  MemoryStream:=TMemoryStream.Create;
  try
    Writer:=TWriter.Create(MemoryStream,4096);
    try
      Writer.RootAncestor := nil;
      Writer.Ancestor := nil;
      Writer.Root := Ctrl.Owner;
      Writer.WriteSignature;
      Writer.WriteComponent(Ctrl);
      Writer.WriteListEnd;
    finally
      Writer.Free;
    end;
  //Paste
    MemoryStream.Position:=0;
    Reader:=TReader.Create(MemoryStream,4096);
    try
      Reader.OnSetName:=CheckName;
      Reader.ReadComponents(aParent.Owner,aParent,ComponentsProc);
    finally
      Reader.Free;
    end;
  finally
    MemoryStream.Free;
    Ctrl.Name:=S;
  end;
end;

procedure TDsnRegister.CheckName(Reader:TReader; Component:TComponent; var Name:String);
begin
  DsnCheckName(Owner,Reader,Component,Name);

  PostMessage(FDsnStage.Handle, DR_CREATED, Integer(Component),0)

end;

procedure TDsnRegister.Cut;
begin
  if not Assigned(FTargetList) then
    Exit;
  if FTargetList.Count = 0 then
    Exit;
  if not SameParent then
    Exit;

  Copy;
  Delete;
end;

function TDsnRegister.CanCopy:Boolean;
begin
  Result:= False;
  if not Assigned(FTargetList) then
    Exit;
  if FTargetList.Count = 0 then
    Exit;
  if not SameParent then
    Exit;
  Result:= True;
end;

procedure TDsnRegister.Copy;
var
  CF_SPECIAL:Cardinal;
  MS: TMemoryStream;
  WR:TWriter;
  HMem: THandle;
  PMem: Pointer;
  PL: PLongInt;
  i:integer;
begin
  if not CanCopy then
    Exit;


  MS := TMemoryStream.Create;

  WR:=TWriter.Create(MS,4096);
  try
    WR.RootAncestor := nil;
    WR.Ancestor := nil;
    WR.Root := Owner;
    for i:= 0 to FTargetList.Count -1 do
    begin
      WR.WriteSignature;
      WR.WriteComponent(TComponent(FTargetList[i]));
    end;
    WR.WriteListEnd;
  finally
    WR.Free;
  end;
  HMem := GlobalAlloc(GHND, MS.Size + SizeOf (LongInt));
  PMem := GlobalLock(HMem);

  PL := PLongInt(PMem);
  PL^ := MS.Size;
  Inc(PL);
  PMem := Pointer(PL);

  MS.Seek(0,0);
  MS.ReadBuffer(PMem^, MS.Size);

  CF_SPECIAL := RegisterClipboardFormat (Dsn_ClipboardFormat);

  GlobalUnlock(HMem);
  Clipboard.Open;
  Clipboard.SetAsHandle(CF_SPECIAL, HMem);

  Clipboard.Close;

  MS.Free;
end;

function TDsnRegister.CanPaste:Boolean;
var
  Control:TWinControl;
  CF_SPECIAL:Cardinal;
begin
  Result:= False;
  if not Assigned(FTargetList) then
    Exit;
  if FTargetList.Count > 1 then
    Exit;
  if FTargetList.Count = 1 then
  begin
    Control:= TWinControl(FTargetList[0]);
    if not (csAcceptsControls in Control.ControlStyle) then
      Exit;
  end;
  CF_SPECIAL := RegisterClipboardFormat(Dsn_ClipboardFormat);
  if not Clipboard.HasFormat(CF_SPECIAL) then
    Exit; 
  Result:= True;
end;

function TDsnRegister.PasteZero:TWinControl;
begin
  Result:= FDsnStage;
end;

procedure TDsnRegister.Paste;
var
  MS: TMemoryStream;
  HMem: THandle;
  PMem: Pointer;
  Size: LongInt;
  RD:TReader;
  Control:TWinControl;
  CF_SPECIAL:Cardinal;
begin
  if not CanPaste then
    Exit;
  Control:= nil;
  if FTargetList.Count = 1 then
    Control:= TWinControl(FTargetList[0]);
  if FTargetList.Count = 0 then
    Control:= PasteZero;
  if Control = nil then
    Exit;

  FTargetList.Clear;
  CF_SPECIAL := RegisterClipboardFormat(Dsn_ClipboardFormat);


  MS := TMemoryStream.Create;

  try
    Clipboard.Open;
    try
      HMem := GetClipboardData(CF_SPECIAL);
      if HMem = 0 then
      begin
        Clipboard.Close;
        MS.Free;
        Exit;
      end;
      PMem := GlobalLock(HMem);
      Size := PLongInt(PMem)^;
      PMem := Pointer(LongInt(PMem)+SizeOf(LongInt));
      try
        MS.WriteBuffer(PMem^, Size);
      finally
        GlobalUnlock(HMem);
      end;
    finally
      Clipboard.Close;
    end;

    MS.Seek(0,0);

    RD:=TReader.Create(MS,4096);
    try
      RD.OnSetName:=CheckName;
      //RD.OnError:=ReadError;
      //RD.OnFindMethod:=FindMethod;
      RD.Position:=0;
      RD.ReadComponents(Owner,Control,ComponentsProcClipbrd);
    finally
      RD.Free;
    end;
  finally
    MS.Free;
  end;
  FTargetList.SetPosition;
end;

procedure TDsnRegister.ComponentsProcClipbrd(Component:TComponent);
var
  Control: TControl;
begin
  if Component is TWinControl then
    SetSubClass(TWinControl(Component));

  if Component is TControl then
  begin
    Control:= TControl(Component);
    if Control.Left > Control.Parent.Width then
      Control.Left:= Control.Parent.Width - Control.Width;
    if Control.Left < 0 then
      Control.Left:= 0;
    if Control.Top > Control.Parent.Height then
      Control.Top:= Control.Parent.Height - Control.Height;
    if Control.Top < 0 then
      Control.Top:= 0;
  end;
  FTargetList.Add(Component);
end;

procedure TDsnRegister.Cutting(var X, Y: Integer);
begin
  if CutSizeX > 0 then
    X:= (X div CutSizeX) * CutSizeX;
  if CutSizeY > 0 then
    Y:= (Y div CutSizeY) * CutSizeY; 
end;

function TDsnRegister.SameParent:Boolean;
var
  i:integer;
  AParent:TWinControl;
begin
  result:= True;
  if Assigned(FTargetList) then
  begin
    if FTargetList.Count > 0 then
    begin
      AParent:= TControl(FTargetList[0]).Parent;
      for i:= 1 to FTargetList.Count -1 do
        if TControl(FTargetList[i]).Parent <> AParent then
        begin
          result:= False;
          Break;
        end;
    end;
  end;
end;

function CompareParent(Item1, Item2: Pointer): Integer;
var
  AParent: TWinControl;
begin
  Result:= 0;
  if UDsnStage = nil then Exit;
  AParent:= TControl(Item1).Parent;
  while AParent <> UDsnStage do
  begin
    AParent:= AParent.Parent;
    Inc(Result);
  end;
  AParent:= TControl(Item2).Parent;
  while AParent <> UDsnStage do
  begin
    AParent:= AParent.Parent;
    Dec(Result);
  end;
end;

procedure TDsnRegister.SortForDelete(List: TList);
begin
  UDsnStage:= FDsnStage;
  List.Sort(CompareParent);
  UDsnStage:= nil;
end;

procedure TDsnRegister.Delete;
var
  i:integer;
  LList:TList;
  CanDelete: Boolean;
begin
  if Assigned(FTargetList) then
  begin
    LList:= TList.Create;
    for i:= 0 to FTargetList.Count -1 do
      LList.Add(FTargetList[i]);
    FTargetList.Clear;
    //Dlete Query
    if FDsnStage <> nil then
      if Assigned(FDsnStage.OnDeleteQuery) then
        for i:= LList.Count -1 downto 0 do
        begin
          CanDelete:= True;
          FDsnStage.OnDeleteQuery(FDsnStage,TComponent(LList[i]),CanDelete);
          if not CanDelete then
            LList.Delete(i);
        end;
    //Sort from Grandchild to DsnStage
    SortForDelete(LList);
    //Delete
    for i:= LList.Count -1 downto 0 do
      TControl(LList[i]).Free;
    LList.Free;
    FTargetList.SetPosition;
  end;
end;

procedure TDsnRegister.AddNotifies(List: TReceiveTargets);
begin
  if DsnNotifies = nil then
    DsnNotifies:= TList.Create;
  DsnNotifies.Add(List);
end;

{procedure TDsnRegister.AddReceiveTargets(List: TReceiveTargets);
begin
  FTargetList.SelectNotification(List);
end;}

procedure TDsnRegister.AddPartners(Partner: TDsnPartner);
begin
  if DsnPartners = nil then
    DsnPartners:= TList.Create;
  DsnPartners.Add(Partner);
end;

procedure TDsnRegister.RemovePartners(Partner: TDsnPartner);
var
  n: integer;
begin
  if DsnPartners <> nil then
  begin
    n:= DsnPartners.IndexOf(Partner);
    if n > -1 then
      DsnPartners.Delete(n);
  end;
end;

function TDsnRegister.CheckCanSelect(Control: TControl): Boolean;
var
  Flag: Boolean;
  Parent: TWinControl;
  CanCover: TCoverAccept;
  CanSelect: TSelectAccept;
begin
  Result:= False;
  if FDsnStage = nil then
    Exit;
  Parent:= Control.Parent;
  Flag:= False;
  while not (Parent is TForm) do
  begin
    if Parent = FDsnStage then
    begin
      Flag:= True;
      Break;
    end;
    Parent:= Parent.Parent;
    if Parent = nil then
      Break;
  end;
  if Flag then
  begin
    CanCover:= caAllAccept;
    if Control is TWinControl then
    begin
      if Assigned(FDsnStage.OnCoverQuery) then
      begin
        FDsnStage.OnCoverQuery(Self,Control,CanCover);
      end;
    end
    else
    begin
      Parent:= Control.Parent;
      if Assigned(FDsnStage.OnCoverQuery) then
      begin
        FDsnStage.OnCoverQuery(Self,Parent,CanCover);
      end;
    end;
    if CanCover = caAllAccept then
      Result:= True;
    if Result then
    begin
      CanSelect:= [saCreate, saMove];

      if Assigned(FDsnStage.OnSelectQuery) then
        FDsnStage.OnSelectQuery(Self, Control, CanSelect);

      if not (saMove in CanSelect) then
        Result:= False;
    end;
  end;
end;

{ TDsnStage }
constructor TDsnStage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FRubberband:=TRubberband.Create;
  FRubberband.Color:=clGray;
  FRubberband.PenWidth:=2;
  FRubberband.MoveWidth:=8;
  FRubberband.MoveHeight:=8;
  FSelfProps:=TStringList.Create;
  FOutProps:=TStringList.Create;
  FDesigning:= False;
end;

destructor TDsnStage.Destroy;
begin
  FRubberband.Free;
  FSelfProps.Free;
  FOutProps.Free;
  inherited;
end;

procedure TDsnStage.SetDesignig(Value:Boolean);
begin
end;

procedure TDsnStage.ClientDeth(var Message:TMessage);
var
  DsnCtrl:TDsnCtrl;
begin
  DsnCtrl:= TDsnCtrl(Message.WParam);
  if DsnCtrl.ClientDeath then
    DsnCtrl.Free
  else
    DsnCtrl.ChangeHandele(DsnCtrl.Client.Handle);
end;

procedure TDsnStage.PropertyChanged(var Message:TMessage);
begin
  UpdateControl;
end;

function TDsnStage.GetControls(Index:Integer):TControl;
begin
  Result:= FDsnRegister.FTargetList[Index];
end;

function TDsnStage.TargetsCount:Integer;
begin
  Result:= -1;
  if Assigned(FDsnRegister) then
    if Assigned(FDsnRegister.FTargetList) then
      Result:= FDsnRegister.FTargetList.Count;
end;

procedure TDsnStage.UpdateControl;
begin
  if Assigned(FDsnRegister) then
    if Assigned(FDsnRegister.FTargetList) then
      FDsnRegister.FTargetList.SetPosition;
end;

procedure TDsnStage.SetSelfProps(Value: TStrings);
begin
  FSelfProps.Assign(Value);
end;

procedure TDsnStage.SetOutProps(Value: TStrings);
begin
  FOutProps.Assign(Value);
end;

procedure TDsnStage.WMKeyUp(var Message: TWmKeyUp);
begin
  if (Message.CharCode in [VK_DELETE]) then
  begin
    Delete;
    Message.Result:=1;
  end;

  inherited;
end;

procedure TDsnStage.KeyPress;
begin
  if Key in [^C] then
  begin
    Key := #0;
    Copy;
  end;

  if Key in [^X] then
  begin
    Key := #0;
    Cut;
  end;

  if Key in [^V] then
  begin
    Key := #0;
    Paste;