rvbutton.pas

自己编写的DBF数据库游览软件,包含TDBF控软件.

unit RVButton;

interface 

uses 
  SysUtils, Classes, Controls, Messages, Graphics, Windows; 

const
  iOffset = 3; 

type 
  TRVButton = class(TGraphicControl) 
  private 
    FCaption : string; 
    FButtonColor: TColor; 
    FLButtonDown: boolean; 
    FBtnPoints : array[1..2] of TPoint; 
    FKRgn : HRgn; 
    procedure SetCaption(Value: string); 
    procedure SetButtonColor(Value: TColor); 
    procedure FreeRegion; 
  protected 
    procedure Paint; override; 
    procedure DrawCircle; 
    procedure MoveButton; 
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; 
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP; 
  public 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
  published 
    property ButtonColor: TColor read FButtonColor write SetButtonColor; 
    property Caption: string read FCaption write SetCaption; 
    property Enabled; 
    property Font; 
    property ParentFont; 
    property ParentShowHint; 
    property ShowHint; 
    property Visible; 
    property OnClick; 
  end; 

procedure Register; 

implementation 

procedure Register; 
begin 
  RegisterComponents('Samples', [TRVButton]); 
end; 

{ TRVButton } 

constructor TRVButton.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  ControlStyle := [csClickEvents,csCaptureMouse]; 
  Width := 50; 
  Height := 50; 
  FButtonColor := clBtnFace; 
  FKRgn := 0; 
  FLButtonDown := False; 
end; 

destructor TRVButton.Destroy; 
begin 
  if FKRgn <> 0 then FreeRegion; 
  inherited Destroy; 
end; 

procedure TRVButton.DrawCircle; 
begin 
  FBtnPoints[1] := Point(iOffset,iOffset); 
  FBtnPoints[2] := Point(Width - iOffset,Height - iOffset); 
  FKRgn := CreateEllipticRgn(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y); 
  Canvas.Brush.Color := FButtonColor; 
  FillRgn(Canvas.Handle,FKRgn,Canvas.Brush.Handle); 
  MoveButton; 
end; 

procedure TRVButton.FreeRegion; 
begin 
  if FKRgn <> 0 then DeleteObject(FKRgn); 
  FKRgn := 0; 
end; 

procedure TRVButton.MoveButton; 
var 
  Color1: TColor; 
  Color2: TColor; 
begin 
  with Canvas do 
    begin 
    if not FLButtonDown then 
      begin 
      Color1 := clBtnHighlight; 
      Color2 := clBtnShadow; 
      end 
    else 
      begin 
      Color1 := clBtnShadow; 
      Color2 := clBtnHighLight; 
      end; 

      Pen.Width := 1; 

      if FLButtonDown then Pen.Color := clBlack 
      else                 Pen.Color := Color2; 

      Ellipse(FBtnPoints[1].x - 2,FBtnPoints[1].y - 2,FBtnPoints[2].x + 2,FBtnPoints[2].y + 2); 

      if not FLButtonDown then Pen.Width := 2 
      else                     Pen.Width := 1; 

      Pen.Color := Color1; 

      Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y, 
          FBtnPoints[2].x,FBtnPoints[1].y,FBtnPoints[1].x,FBtnPoints[2].y); 

      Pen.Color := Color2; 

      Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y, 
          FBtnPoints[1].x,FBtnPoints[2].y,FBtnPoints[2].x,FBtnPoints[1].y); 
      end; 

  SetCaption(''); 
end; 

procedure TRVButton.Paint; 
begin 
  inherited Paint; 
  FreeRegion; 
  DrawCircle; 
end; 

procedure TRVButton.SetButtonColor(Value: TColor); 
begin 
  if Value <> FButtonColor then 
    begin 
    FButtonColor := Value; 
    Invalidate; 
    end; 
end; 

procedure TRVButton.SetCaption(Value: string); 
var 
  X: Integer; 
  Y: Integer; 
begin 
  if ((Value <> FCaption) and (Value <> '')) then 
  begin 
    FCaption := Value; 
  end; 

  with Canvas.Font do 
  begin 
    Name  := Font.Name; 
    Size  := Font.Size; 
    Style := Font.Style; 
    if Self.Enabled then Color := Font.Color 
    else 
      Color := clDkGray; 
  end; 

  X := (Width div 2) - (Canvas.TextWidth(FCaption) div 2); 
  Y := (Height div 2) - (Canvas.TextHeight(FCaption) div 2); 
  Canvas.TextOut(X, Y, FCaption); 
  //  Invalidate; 
end; 


procedure TRVButton.WMLButtonDown(var Message: TWMLButtonDown); 
begin 
  if not PtInRegion(FKRgn,Message.xPos,Message.yPos) then exit; 
  FLButtonDown := True; 
  MoveButton; 
  inherited; 
end; 

procedure TRVButton.WMLButtonUp(var Message: TWMLButtonUp); 
begin 
  if not FLButtonDown then exit; 
  FLButtonDown := False; 
  MoveButton; 
  inherited; 
end; 


end.