sbevel.pas

AlphaControls是一个Delphi标准控件的集合

unit sBevel;

{$I sDefs.inc}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, sConst,
    sStyleUtil, sUtils, sGraphUtils;

type
  TsBevelShape = (sbsBox, sbsFrame, sbsTopLine, sbsBottomLine, sbsLeftLine,
    sbsRightLine, sbsSpacer, sbsDotted{, sbsLabeled});

  TsBevel = class(TGraphicControl)
  private
    FCaption : string;
    FsStyle : TsPaintStyle;
    FShape: TsBevelShape;
    FShowCaption: boolean;
    procedure SetShape(Value: TsBevelShape);
    procedure SetCaption(const Value: string);
    procedure SetShowCaption(const Value: boolean);
  protected
    procedure Paint; override;
    procedure WndProc (var Message: TMessage); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Align;
    property Anchors;
    property Caption : string read FCaption write SetCaption;
    property Constraints;
    property Font;
    property ParentShowHint;
    property Shape: TsBevelShape read FShape write SetShape default sbsFrame;
    property ShowCaption : boolean read FShowCaption write SetShowCaption default False;
    property ShowHint;
    property sStyle : TsPaintStyle read FsStyle write FsStyle;
    property Visible;
  end;

implementation

{ TsBevel }

constructor TsBevel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  sStyle := TsPaintStyle.Create(Self);
  sStyle.COC := COC_TsBevel;

//  ControlStyle := ControlStyle + [csReplicatable];
  FShape := sbsFrame;
  Width := 50;
  Height := 50;
  FShowCaption := False;
end;

destructor TsBevel.Destroy;
begin
  if Assigned(FsStyle) then FreeAndNil(FsStyle);
  inherited Destroy;
end;

procedure TsBevel.Paint;
const
  XorColor = $00FFD8CE;
var
  Color1, Color2: TColor;
  Temp: TColor;
  bmp : TBitmap;
//  notUsed{, dC} : hwnd;

  procedure BevelRect(const R: TRect); begin
    Canvas.Pen.Color := Color1;
    Canvas.PolyLine([Point(R.Left, R.Bottom), Point(R.Left, R.Top), Point(R.Right, R.Top)]);
    Canvas.Pen.Color := Color2;
    Canvas.PolyLine([Point(R.Right, R.Top), Point(R.Right, R.Bottom), Point(R.Left, R.Bottom)]);
  end;

  procedure BevelLine(C: TColor; X1, Y1, X2, Y2: Integer); begin
    Canvas.Pen.Color := C;
    Canvas.MoveTo(X1, Y1);
    Canvas.LineTo(X2, Y2);
  end;

  procedure FreeBmp; begin
    if Assigned(Bmp) then FreeAndNil(Bmp);
  end;
begin
//  notUsed := 0;
//  dc := GetDeviceContext(notUsed);
  if (csDestroying in ComponentState) or (csLoading in ComponentState) then Exit;

  Canvas.Font.Assign(Font);
  Canvas.Brush.Style := bsClear;

  if ShowCaption and (Caption <> '') then begin
    Canvas.TextOut(4, 2, Caption);
  end;

  if (FShape = sbsSpacer) then begin
    Canvas.Pen.Style := psDot;
    Canvas.Pen.Mode := pmXor;
    Canvas.Pen.Color := XorColor;
    Canvas.Rectangle(0, 0, ClientWidth, ClientHeight);
    Exit;
  end
  else if (FShape = sbsDotted) then begin
    FocusRect(Canvas, Rect(1, 1, Width - 1, Height - 1));
    Exit;
  end
  else begin
    Canvas.Pen.Style := psSolid;
    Canvas.Pen.Mode  := pmCopy;
    Canvas.Pen.Color := clBlack;
    Canvas.Brush.Style := bsSolid;
  end;

  Canvas.Pen.Width := 1;

  case sStyle.Painting.Bevel of
    cbLoweredSoft, cbLoweredHard: begin
      Color1 := clBlack;
      Color2 := clWhite;
    end;
    cbRaisedSoft, cbRaisedHard: begin
      Color1 := clWhite;
      Color2 := clBlack;
    end;
    cbNone: begin
      Exit;
    end;
  end;
  Color1 := ColorToRGB(Color1);
  Color2 := ColorToRGB(Color2);

  case FShape of
    sbsBox: BevelRect(Rect(0, 0, Width - 1, Height - 1));
    sbsFrame: begin
      Temp := Color1;
      Color1 := Color2;
      BevelRect(Rect(1, 1, Width - 1, Height - 1));
      Color2 := Temp;
      Color1 := Temp;
      BevelRect(Rect(0, 0, Width - 2, Height - 2));
    end;
    sbsTopLine: begin
      BevelLine(Color1, 0, 0, Width, 0);
      BevelLine(Color2, 0, 1, Width, 1);
    end;
    sbsBottomLine: begin
      BevelLine(Color1, 0, Height - 2, Width, Height - 2);
      BevelLine(Color2, 0, Height - 1, Width, Height - 1);
    end;
    sbsLeftLine: begin
      BevelLine(Color1, 0, 0, 0, Height);
      BevelLine(Color2, 1, 0, 1, Height);
    end;
    sbsRightLine: begin
      BevelLine(Color1, Width - 2, 0, Width - 2, Height);
      BevelLine(Color2, Width - 1, 0, Width - 1, Height);
    end;
  end;
end;

procedure TsBevel.SetCaption(const Value: string);
begin
  if FCaption <> Value then begin
    FCaption := Value;
    sStyle.Invalidate;
  end;
end;

procedure TsBevel.SetShape(Value: TsBevelShape);
begin
  if Value <> FShape then begin
    FShape := Value;
    sStyle.Invalidate;
  end;
end;

procedure TsBevel.SetShowCaption(const Value: boolean);
begin
  if FShowCaption <> Value then begin
    FShowCaption := Value;
    sStyle.Invalidate;
  end;
end;

procedure TsBevel.WndProc(var Message: TMessage);
begin
//  if Assigned(FsStyle) then FsStyle.WndProc(Message);
//  if Message.Result <> 1 then
  inherited;
end;

end.