lazarus-ccr/components/orpheus/o32bordr.pas

{*********************************************************}
{*                   O32BORDR.PAS 4.06                   *}
{*********************************************************}

{* ***** BEGIN LICENSE BLOCK *****                                            *}
{* Version: MPL 1.1                                                           *}
{*                                                                            *}
{* The contents of this file are subject to the Mozilla Public License        *}
{* Version 1.1 (the "License"); you may not use this file except in           *}
{* compliance with the License. You may obtain a copy of the License at       *}
{* http://www.mozilla.org/MPL/                                                *}
{*                                                                            *}
{* Software distributed under the License is distributed on an "AS IS" basis, *}
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License   *}
{* for the specific language governing rights and limitations under the       *}
{* License.                                                                   *}
{*                                                                            *}
{* The Original Code is TurboPower Orpheus                                    *}
{*                                                                            *}
{* The Initial Developer of the Original Code is TurboPower Software          *}
{*                                                                            *}
{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002    *}
{* TurboPower Software Inc. All Rights Reserved.                              *}
{*                                                                            *}
{* Contributor(s):                                                            *}
{*                                                                            *}
{* ***** END LICENSE BLOCK *****                                              *}

{$I OVC.INC}

{$B-} {Complete Boolean Evaluation}
{$I+} {Input/Output-Checking}
{$P+} {Open Parameters}
{$T-} {Typed @ Operator}
{.W-} {Windows Stack Frame}
{$X+} {Extended Syntax}

unit o32bordr;
  {New Style Border control for Orpheus 4 components.}

interface

uses
  {$IFNDEF LCL} Windows, {$ELSE} LclIntf, MyMisc, {$ENDIF}
  Classes, Controls, Graphics;

type
  TO32BorderStyle = (bstyNone, bstyRaised, bstyLowered, bstyFlat, bstyChannel,
                     bstyRidge);

const
  THiliteColor: array[TO32BorderStyle] of TColor = (clWindow, clBtnHighlight,
    clBtnShadow, clWindowFrame, clBtnShadow, clBtnHighlight);

  TBaseColor: array[TO32BorderStyle] of TColor = (clWindow, clBtnShadow,
    clBtnHighlight, clWindowFrame, clBtnHighlight, clBtnShadow);

type
  TO32BorderSide  = (bsidLeft, bsidRight, bsidTop, bsidBottom);

  TSides = (left, right, top, bottom);

  TO32Borders = class;

  TO32BorderSet = class(TPersistent)
  protected {private}
    FOwner       : TPersistent;
    FLeft        : Boolean;
    FTop         : Boolean;
    FRight       : Boolean;
    FBottom      : Boolean;
    procedure SetLeft(Value: Boolean);
    procedure SetRight(Value: Boolean);
    procedure SetBottom(Value: Boolean);
    procedure SetTop(Value: Boolean);
  public
    constructor Create(AOwner: TPersistent);
  published
    property ShowLeft    : Boolean  read FLeft    write SetLeft
      default True;
    property ShowRight   : Boolean  read FRight   write SetRight
      default True;
    property ShowTop     : Boolean  read FTop     write SetTop
      default True;
    property ShowBottom  : Boolean  read FBottom  write SetBottom
      default True;
  end;

  TO32Borders = class(TPersistent)
  protected {private}
    Creating      : Boolean;
    FControl      : TWinControl;
    FBorderSet    : TO32BorderSet;
    FActive       : Boolean;
    FFlatColor    : TColor;
    FBorderWidth  : Integer;
    FBorderStyle  : TO32BorderStyle;
    procedure SetActive       (Value : Boolean);
    procedure SetBorderStyle  (Value : TO32BorderStyle);
    procedure SetFlatColor    (Value : TColor);

    procedure Draw3dBox(Canvas: TCanvas; Rct: TRect; Hilite,
     Base: TColor; DrawAllSides: Boolean);
    procedure DrawFlatBorder(Canvas: TControlCanvas; Rct: TRect;
      Color: TColor{; DrawAllSides: Boolean}); {!!!}
    procedure DrawBevel(Canvas: TControlCanvas; Rct: TRect; HiliteColor,
      BaseColor: TColor);
    procedure Draw3dBorders(Canvas: TControlCanvas; Rct: TRect);
    procedure EraseBorder(Canvas: TControlCanvas; Rct: TRect;
      Color: TColor; AllSides: Boolean);
    procedure DrawSingleSolidBorder(Canvas: TControlCanvas; Rct: TRect;
      Color: TColor; Side: TSides; Width: Integer);
  public
    constructor Create(Control: TWinControl);
    destructor  Destroy; override;
    procedure Changed;
    procedure BordersChanged;
    property  Control: TWinControl read FControl;
    procedure DrawBorders(var Canvas: TControlCanvas; Color: TColor);
    procedure RedrawControl;
  published
    property Active      : Boolean    read FActive       write SetActive
      default False;
    property BorderSet   : TO32BorderSet
                                      read FBorderSet   write FBorderSet;
    property BorderStyle: TO32BorderStyle read FBorderStyle write SetBorderStyle
      default bstyRidge;
    property FlatColor: TColor read FFlatColor write SetFlatColor
      default clLime;
  end;

implementation

{===== TO32BorderSet =================================================}
constructor TO32BorderSet.Create(AOwner: TPersistent);
begin
  inherited Create;
  FOwner := AOwner;
end;
{=====}

procedure TO32BorderSet.SetLeft(Value: Boolean);
begin
  if Value <> FLeft then begin
    FLeft := Value;
    TO32Borders(FOwner).BordersChanged;
  end;
end;
{=====}

procedure TO32BorderSet.SetRight(Value: Boolean);
begin
  if Value <> FRight then begin
    FRight := Value;
    TO32Borders(FOwner).BordersChanged;
  end;
end;
{=====}

procedure TO32BorderSet.SetBottom(Value: Boolean);
begin
  if Value <> FBottom then begin
    FBottom := Value;
    TO32Borders(FOwner).BordersChanged;
  end;
end;
{=====}

procedure TO32BorderSet.SetTop(Value: Boolean);
begin
  if Value <> FTop then begin
    FTop := Value;
    TO32Borders(FOwner).BordersChanged;
  end;
end;

{===== TO32BorderSet - End =====}


{===== TO32Borders =================================================}
constructor TO32Borders.Create(Control: TWinControl);
begin
  Creating := True;
  inherited Create;
  FControl := Control;
  FBorderSet := TO32BorderSet.Create(self);
  FActive := false;
  FBorderWidth := 2;
  FBorderStyle := bstyRidge;
  FFlatColor := clLime;
  FBorderSet.ShowBottom := true;
  FBorderSet.ShowLeft := true;
  FBorderSet.ShowRight := true;
  FBorderSet.ShowTop := true;
  Creating := False;
end;
{=====}

destructor  TO32Borders.Destroy;
begin
  FBorderSet.Free;
  inherited Destroy;
end;
{=====}

procedure TO32Borders.SetActive(Value: Boolean);
begin
  if FActive <> Value then begin
    FActive := Value;
    Changed;
  end;
end;
{=====}

procedure TO32Borders.SetBorderStyle(Value: TO32BorderStyle);
begin
  if Value <> FBorderStyle then begin
    FBorderStyle := Value;
    Changed;
  end;
end;
{=====}

procedure TO32Borders.SetFlatColor(Value: TColor);
begin
  if Value <> FFlatColor then begin
    FFlatColor := Value;
    if FBorderStyle = bstyFlat then
      Changed;
  end;
end;
{=====}

procedure TO32Borders.DrawBorders(var Canvas: TControlCanvas; Color: TColor);
var
  Rct     : TRect;
begin
  if not FActive then exit;

  Rct := Rect(0, 0, FControl.Width, FControl.Height);

  {Erase the existing border.}
  EraseBorder(Canvas, Rct, Color, true);

  {If the border style is bstyNone then don't do anything else.}
  if FBorderStyle = bstyNone then exit;

  {otherwise, draw the border.}
  if FBorderStyle = bstyFlat then
    DrawFlatBorder(Canvas, Rct, FFlatColor{, false})
  else Draw3dBorders(Canvas, Rct);
end;
{=====}

procedure TO32Borders.Draw3dBorders(Canvas: TControlCanvas; Rct: TRect);
var
  Hilite, Base: TColor;
  R: TRect;
begin
  Hilite := THiliteColor[FBorderStyle];
  Base   := TBaseColor[FBorderStyle];

  if FBorderStyle in [bstyLowered, bstyRaised ] then
    DrawBevel(Canvas, Rct, Hilite, Base)

  else with FBorderSet do begin
    R := Rct;
    {Patch the border edges}

    if ShowRight then
      Canvas.Pixels[R.Right - 1, R.Top] := Base;
    if ShowTop and not ShowRight then
      Canvas.Pixels[R.Right - 1, R.Top] := Hilite;
    if ShowBottom then
      Canvas.Pixels[R.Left, R.Bottom - 1] := Base;
    if ShowLeft and not ShowBottom then
      Canvas.Pixels[R.Left, R.Bottom - 1] := Hilite;
    if ShowTop and not ShowLeft then
      Canvas.Pixels[R.Left, R.Top + 1] := Base;
    if not ShowTop and ShowLeft then
      Canvas.Pixels[R.Left + 1, R.Top] := Base;
    if ShowBottom and not ShowRight then
      Canvas.Pixels[R.Right - 1, R.Bottom - 2] := Hilite;
    if not ShowBottom and ShowRight then
      Canvas.Pixels[R.Right - 2, R.Bottom - 1] := Hilite;

    Inc( R.Left );
    Inc( R.Top );
    Draw3dBox(Canvas, R, Base, Base, false);
    OffsetRect(R, -1, -1);
    Draw3dBox(Canvas, R, Hilite, Hilite, false);

{ - dead code}
//    if ShowLeft   then Inc(Rct.Left,   2);
//    if ShowTop    then Inc(Rct.Top,    2);
//    if ShowRight  then Dec(Rct.Right,  2);
//    if ShowBottom then Dec(Rct.Bottom, 2);
  end;
end;
{=====}

procedure TO32Borders.DrawSingleSolidBorder(Canvas: TControlCanvas; Rct: TRect;
  Color: TColor; Side: TSides; Width: Integer);
var
  i: Integer;
begin
  with Canvas, FBorderSet do begin
    Pen.Width := 1;
    Pen.Color := Color;

    if Side = left then
      for i := 0 to Width do begin
        MoveTo(Rct.Left - 1, Rct.Top);
        LineTo(Rct.Left - 1, Rct.Bottom);
        Inc(Rct.Left);
      end
    else if Side = right then
      for i := 0 to Width do begin
        MoveTo(Rct.Right , Rct.Top);
        LineTo(Rct.Right , Rct.Bottom);
        Dec(Rct.Right);
      end
    else if Side = top then
      for i := 0 to Width do begin
        MoveTo(Rct.Left, Rct.Top - 1);
        LineTo(Rct.Right, Rct.Top - 1);
        Inc(Rct.Top);
      end
    else if Side = bottom then
      for i := 0 to Width do begin
        MoveTo(Rct.Left, Rct.Bottom);
        LineTo(Rct.Right, Rct.Bottom);
        Dec(Rct.Bottom);
      end;
  end;
end;
{=====}

procedure TO32Borders.Draw3dBox(Canvas: TCanvas; Rct: TRect; Hilite,
  Base: TColor; DrawAllSides: Boolean);
begin
  with Canvas, Rct, FBorderSet do begin
    Pen.Width := 1;
    Pen.Color := Hilite;
    if ShowLeft or DrawAllSides then begin
      MoveTo( Left, Top );
      LineTo( Left, Bottom );
    end;

    if ShowTop or DrawAllSides then begin
      MoveTo( Left, Top );
      LineTo( Right, Top );
    end;

    Pen.Color := Base;
    if ShowRight or DrawAllSides then begin
      MoveTo( Right - 1, Top );
      LineTo( Right - 1, Bottom );
    end;

    if ShowBottom or DrawAllSides then begin
      MoveTo( Left, Bottom - 1 );
      LineTo( Right, Bottom - 1 );
    end;
  end;
end;
{=====}

procedure TO32Borders.DrawBevel(Canvas: TControlCanvas; Rct: TRect; HiliteColor,
  BaseColor: TColor);
var
  I: Integer;
begin
  Canvas.Pen.Width := 1;
  for I := 1 to FBorderWidth do
  begin
    Draw3dBox(Canvas, Rct, HiliteColor, BaseColor, False);
    Inc(Rct.Left);
    Inc(Rct.Top);
    Dec(Rct.Right);
    Dec(Rct.Bottom);
  end;
end;
{=====}

procedure TO32Borders.DrawFlatBorder(Canvas: TControlCanvas; Rct: TRect;
  Color: TColor{; DrawAllSides: Boolean});
begin
  Canvas.Pen.Color := Color;
  with BorderSet do begin
    if ShowLeft then
      DrawSingleSolidBorder(Canvas, Rct, Color, left, FBorderWidth);
    if ShowRight then
      DrawSingleSolidBorder(Canvas, Rct, Color, right, FBorderWidth);
    if ShowTop then
      DrawSingleSolidBorder(Canvas, Rct, Color, top, FBorderWidth);
    if ShowBottom then
      DrawSingleSolidBorder(Canvas, Rct, Color, bottom, FBorderWidth);
  end;
end;
{=====}

procedure TO32Borders.EraseBorder(Canvas: TControlCanvas; Rct: TRect;
  Color: TColor; AllSides: Boolean);
var
  i: Integer;
begin
  Canvas.Pen.Color := Color;
  with BorderSet do begin
    for i := 1 to FBorderWidth do begin
      Draw3dBox(Canvas, Rct, Color, Color, AllSides);
      Inc(Rct.Left);
      Inc(Rct.Top);
      Dec(Rct.Right);
      Dec(Rct.Bottom);
    end;
  end;
end;
{=====}

procedure TO32Borders.BordersChanged;
begin
  if FActive then Changed;
end;
{=====}

procedure TO32Borders.RedrawControl;
var
  Rct: TRect;
begin
  if not Creating then begin
    Rct := FControl.ClientRect;
    RedrawWindow(FControl.Handle, @Rct, 0,
      rdw_Invalidate or rdw_UpdateNow or rdw_Frame );
  end;
end;
{=====}

procedure TO32Borders.Changed;
begin
  FControl.Invalidate;
  RedrawControl;
end;

{===== TO32Borders - End =====}

end.