source: branches/Xvcl/Xvcl.Controls.pas

unit Xvcl.Controls;

interface

uses
  Xvcl.Generics, Xvcl.Classes, Xvcl.Graphics;

type
  TControl = class;
  TWinControl = class;

  TMessage = class
    Number: Integer;
    Handled: Boolean;
  end;

  TMouseButton = (mbLeft, mbRight, mbMiddle);
  TMouseButtonSet = set of TMouseButton;
  TMessageMouse = class(TMessage)
    Position: TPoint;
    Buttons: TMouseButtonSet;
  end;
  TMessageMouseDown = class(TMessageMouse);
  TMessageMouseUp = class(TMessageMouse);
  TMessageMouseMove = class(TMessageMouse);

  TKeyState = (ksShift, ksAlt, ksOS);
  TKeyStateSet = set of TKeyState;
  TMessageKeyboard = class(TMessage)
    KeyCode: Integer;
    States: TKeyStateSet;
  end;

  TControlCanvas = class(TCanvas)
  protected
    function GetVideoDevice: TVideoDevice; override;
  public
    Control: TControl;
    function AdjustPos(Position: TPoint): TPoint; override;
  end;

  TControlMove = class
    Control: TControl;
    StartControlPos: TPoint;
    StartMousePos: TPoint;
    Active: Boolean;
  end;

  TControl = class(TComponent)
  private
    FCanvas: TControlCanvas;
    FParent: TWinControl;
    FVisible: Boolean;
    FBounds: TRectangle;
    FOnClick: TNotifyEvent;
    FColor: TColor;
    FOnMouseDown: TNotifyEvent;
    FOnMouseUp: TNotifyEvent;
    function GetCanvas: TCanvas;
    procedure SetParent(const Value: TWinControl); virtual;
    procedure SetColor(const Value: TColor);
  protected
    function GetVideoDevice: TVideoDevice; virtual;
    function HandleMessage(Message: TMessage): Boolean; virtual;
  public
    Move: TControlMove;
    function ClientToScreen(Position: TPoint): TPoint; virtual;
    function ScreenToClient(Position: TPoint): TPoint; virtual;
    procedure Paint; virtual;
    constructor Create; override;
    destructor Destroy; override;
    property Bounds: TRectangle read FBounds write FBounds;
    property Visible: Boolean read FVisible write FVisible;
    property Canvas: TCanvas read GetCanvas;
    property Parent: TWinControl read FParent write SetParent;
    property VideoDevice: TVideoDevice read GetVideoDevice;
    property Color: TColor read FColor write SetColor;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnMouseDown: TNotifyEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp: TNotifyEvent read FOnMouseUp write FOnMouseUp;
  end;

  TWinControl = class(TControl)
  protected
    function HandleMessage(Message: TMessage): Boolean; override;
  public
    Controls: TList<TControl>;
    procedure Paint; override;
    constructor Create; override;
    destructor Destroy; override;
  end;

  TButton = class(TControl)
  private
    FCaption: string;
    procedure SetCaption(const Value: string);
  public
    procedure Paint; override;
    constructor Create; override;
    property Caption: string read FCaption write SetCaption;
  end;

  TLabel = class(TControl)
  private
    FCaption: string;
    procedure SetCaption(const Value: string);
  public
    procedure Paint; override;
    property Caption: string read FCaption write SetCaption;
  end;


implementation

{ TControl }

function TControl.ClientToScreen(Position: TPoint): TPoint;
begin
  Result := Position.Add(Bounds.TopLeft);
  if Assigned(Parent) then Result := Parent.ClientToScreen(Result);
end;

constructor TControl.Create;
begin
  inherited;
  Move := TControlMove.Create;
  FColor := clWhite;
end;

destructor TControl.Destroy;
begin
  Move.Destroy;
  if Assigned(FCanvas) then FCanvas.Destroy;
  inherited;
end;

function TControl.GetCanvas: TCanvas;
begin
  if not Assigned(FCanvas) then begin
    FCanvas := TControlCanvas.Create;
    FCanvas.Control := Self;
  end;
  Result := FCanvas;
end;

function TControl.GetVideoDevice: TVideoDevice;
begin
  if Assigned(Parent) then Result := Parent.VideoDevice
    else Result := nil;
end;

function TControl.HandleMessage(Message: TMessage): Boolean;
begin
  Result := False;
  if Message is TMessageMouseDown then begin
    if Assigned(FOnMouseDown) then FOnMouseDown(Self);
    Color := clGray;
    Paint;
    Result := True;
  end else
  if Message is TMessageMouseUp then begin
    if Assigned(FOnMouseUp) then FOnMouseUp(Self);
    Color := clSilver;
    Paint;
    if Assigned(FOnClick) then FOnClick(Self);
    Result := True;
  end;
end;

procedure TControl.Paint;
begin
  with Canvas do begin
    Brush.Color := Color;
    FillRect(TRectangle.Create(0, 0, Bounds.Width, Bounds.Height));
  end;
end;

function TControl.ScreenToClient(Position: TPoint): TPoint;
begin
  Result := Position.Substract(Bounds.TopLeft);
  if Assigned(Parent) then Result := Parent.ClientToScreen(Result);
end;

procedure TControl.SetColor(const Value: TColor);
begin
  if FColor <> Value then begin
    FColor := Value;
    Paint;
  end;
end;

procedure TControl.SetParent(const Value: TWinControl);
begin
  if FParent <> Value then begin
    if Assigned(FParent) then Parent.Controls.Remove(Self);
    FParent := Value;
    if Assigned(FParent) then Parent.Controls.Add(Self);
  end;
end;

{ TButton }

constructor TButton.Create;
begin
  inherited;
  FColor := clSilver;
end;

procedure TButton.Paint;
begin
  inherited;
  with Canvas do begin
    MoveTo(TPoint.Create(0, 0));
    LineTo(TPoint.Create(Bounds.Width - 1, 0));
    LineTo(TPoint.Create(Bounds.Width - 1, Bounds.Height - 1));
    LineTo(TPoint.Create(0, Bounds.Height - 1));
    LineTo(TPoint.Create(0, 0));
    TextOut(TPoint.Create((Bounds.Width - GetTextSize(Caption).X) div 2,
      (Bounds.Height - GetTextSize(Caption).Y) div 2), Caption);
  end;
end;

procedure TButton.SetCaption(const Value: string);
begin
  if FCaption <> Value then begin
    FCaption := Value;
    Paint;
  end;
end;

{ TControlCanvas }

function TControlCanvas.AdjustPos(Position: TPoint): TPoint;
begin
  if Assigned(Control) then
    Result := Control.ClientToScreen(Position)
    else Result := inherited;
end;

function TControlCanvas.GetVideoDevice: TVideoDevice;
begin
  if Assigned(Control) then Result := Control.VideoDevice
    else Result := nil;
end;

{ TWinControl }

constructor TWinControl.Create;
begin
  inherited;
  Controls := TList<TControl>.Create;
end;

destructor TWinControl.Destroy;
begin
  Controls.Destroy;
  inherited;
end;

function TWinControl.HandleMessage(Message: TMessage): Boolean;
var
  Control: TControl;
begin
  Result := False;
  for Control in Controls do begin
    if Message is TMessageMouse then
    with TMessageMouse(Message) do begin
    if Control.Bounds.Contains(ScreenToClient(Position)) then begin
      if TWinControl(Control).HandleMessage(Message) then begin
        Result := True;
        Break;
      end;
    end;
  end;
  end;
end;

procedure TWinControl.Paint;
var
  C: TControl;
begin
  inherited;
  for C in Controls do C.Paint;
end;

{ TLabel }

procedure TLabel.Paint;
begin
  inherited;
  with Canvas do begin
    TextOut(TPoint.Create((Bounds.Width - GetTextSize(Caption).X) div 2,
      (Bounds.Height - GetTextSize(Caption).Y) div 2), Caption);
  end;
end;

procedure TLabel.SetCaption(const Value: string);
begin
  if FCaption <> Value then begin
    FCaption := Value;
    Paint;
  end;
end;

end.