fcshapebtn.pas

一套及时通讯的原码

unit fcShapeBtn;
{
//
// Components : TfcShapeBtn
//
// Copyright (c) 1999 by Woll2Woll Software
// Revision: History
// 5/10/99 - PYW - Fixed Flat Style painting bug in High Color mode.
// 5/24/2000-PYW-Add check to not paint in 3D if control is disabled.
//
}

interface

{$i fcIfDef.pas}

uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
  CommCtrl, Buttons, Dialogs, Math, Consts, SysUtils, fcCommon, fcText,
  {$ifdef fcDelphi7Up}
  themes,
  {$endif}
  {$ifdef ThemeManager}
  thememgr, themesrv, uxtheme,
  {$endif}
  fcButton, fcImgBtn, fcEvaluator, fcBitmap
  {$ifdef fcDelphi4up}
  ,ImgList, ActnList
  {$endif};

const DEFUNUSECOLOR = clRed;
      DEFUNUSECOLOR2 = clBlue;

type
  TfcShapeOrientation = (soLeft, soRight, soUp, soDown);

{  1/9/2000 - Already in fccommon.pas
  PfcPolyGonPoints = ^TFCPolyGonPoints;
  TfcPolyGonPoints = array[0..0] of TPoint;
}
  TfcButtonShape = (bsRoundRect, bsEllipse, bsTriangle, bsArrow, bsDiamond,
    bsRect, bsStar, bsTrapezoid, bsCustom);

  TwwComputeCanvasAttributes = Procedure(
     Sender: TObject; ACanvas: TCanvas) of object;

  TfcCustomShapeBtn = class(TfcCustomImageBtn)
  private
    // Property Storage Variables
    FPointList: TStringList;
    FShape: TfcButtonShape;
    FOrientation: TfcShapeOrientation;
    FRoundRectBias: Integer;
    FRegionBitmap: TBitmap;
    FOnComputeCanvasAttributes: TwwComputeCanvasAttributes;

    // Propety Access Methods
    procedure SetShape(Value: TfcButtonShape);
    procedure SetOrientation(Value: TfcShapeOrientation);
    procedure SetPointList(Value: TStringList);
    procedure SetRoundRectBias(Value: Integer);
    function CorrectedColor: TColor;
  protected
    procedure DoComputeCanvasAttributes(ACanvas: TCanvas); virtual;
    procedure WndProc(var Message: TMessage); override;
    function StoreRegionData: Boolean; override;
    function UnusableColor: TColor;
    procedure AssignTo(Dest: TPersistent); override;
    procedure Draw3dLines(Bitmap: TfcBitmap; PointList: array of TPoint;
      NumPoints: Integer; TransColor: TColor);
    procedure SetPointToOrientation(Points: PFCPolygonPoints;
      NumPoints: Integer; Orientation: TfcShapeOrientation; Size: TSize);
    function GetCustomPoints(var Points: PFCPolygonPoints; Size: TSize): Integer;
    function GetStarPoints(var Points: PFCPolygonPoints; Size: TSize): Integer;
    function GetPolygonPoints(var Points: PFCPolyGonPoints): Integer;

    // Overriden Methods
    function CreateRegion(DoImplementation: Boolean; Down: Boolean): HRgn; override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    function UseRegions: boolean; override;


    property RegionBitmap: TBitmap read FRegionBitmap write FRegionBitmap;
  public
    Patch: Variant;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function IsMultipleRegions: Boolean; override;
    function RoundShape: Boolean; virtual;
    procedure GetDrawBitmap(DrawBitmap: TfcBitmap; ForRegion: Boolean;
      ShadeStyle: TfcShadeStyle; Down: Boolean); override;
    procedure SizeToDefault; override;

    property Orientation: TfcShapeOrientation read FOrientation write SetOrientation default soUp;
    property PointList: TStringList read FPointList write SetPointList;
    property RoundRectBias: Integer read FRoundRectBias write SetRoundRectBias default 0;
    property Shape: TfcButtonShape read FShape write SetShape default bsRect;
    property OnComputeCanvasAttributes: TwwComputeCanvasAttributes read
       FOnComputeCanvasAttributes write FOnComputeCanvasAttributes;
  end;

  TfcShapeBtn = class(TfcCustomShapeBtn)
  published
    {$ifdef fcDelphi4Up}
    property Action;
    property Anchors;
    property Constraints;
    {$endif}
    property StaticCaption;
    property AllowAllUp;
    property Cancel;
    property Caption;
    property Color;
    property Default;
    property DitherColor;
    property Down;
    property DragCursor; //3/31/99 - PYW - Exposed DragCursor, DragMode, DragKind properties.
    property DataSource;
    property DataField;

    {$ifdef fcDelphi4Up}
    property DragKind;
    {$endif}
    property DragMode;
    property Font;
    property Enabled;
    property Glyph;
    property GroupIndex;
    property Kind;
    property Layout;
    property Margin;
    property ModalResult;
    property NumGlyphs;
    property Options;
    property Offsets;
    property Orientation;
    property ParentClipping;
    property ParentFont;
    property ParentShowHint;
    property PointList;
    property PopupMenu;
    property RoundRectBias;
    property ShadeColors;
    property ShadeStyle;
    property Shape;
    property ShowHint;
    {$ifdef fcDelphi4Up}
    property SmoothFont;
    {$endif}
    property Spacing;
    property Style;
    property TabOrder;
    property TabStop;
    property TextOptions;
    property Visible;
    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnSelChange;
    property OnStartDrag;
    property OnComputeCanvasAttributes;
    property DisableThemes;
  end;

implementation

var GoodVideoDriverVar: Integer = -1;

function GoodVideoDriver: Boolean;
var TmpBm: TfcBitmap;
    TmpBitmap: TBitmap;
begin
  if GoodVideoDriverVar = -1 then
  begin
    TmpBm := TfcBitmap.Create;
    TmpBm.LoadBlank(1, 1);
    TmpBm.Pixels[0, 0] := fcGetColor(RGB(192, 192, 192));
    TmpBitmap := TBitmap.Create;
    TmpBitmap.Width := 1;
    TmpBitmap.Height := 1;
    TmpBitmap.Canvas.Draw(0, 0, TmpBm);
    with fcGetColor(TmpBitmap.Canvas.Pixels[0, 0]) do
      GoodVideoDriverVar := ord((r < 200) and (g < 200) and (b < 200));
    TmpBitmap.Free;
    TmpBm.Free;
  end;
  result := GoodVideoDriverVar = 1;
end;

{$R-}

procedure TfcCustomShapeBtn.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  exit;

  if (Button = mbLeft) and Enabled then
  begin
    if not Down then
    begin
      Down:=False;
      Invalidate;
    end;
  end;
end;

constructor TfcCustomShapeBtn.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  UseHalftonePalette:= False;
  FPointList := TStringList.Create;
  FShape := bsRect;
  FOrientation := soUp;
  FRoundRectBias := 25;
  FRegionBitmap := TBitmap.Create;
  Color := clBtnFace;
  ShadeStyle := fbsHighlight;
end;

destructor TfcCustomShapeBtn.Destroy;
begin
  FPointList.Free;
  FRegionBitmap.Free;
  inherited;
end;

procedure TfcCustomShapeBtn.SetOrientation(Value: TfcShapeOrientation);
begin
  if FOrientation<> Value then
  begin
    FOrientation:= Value;
    Recreatewnd;
  end
end;

procedure TfcCustomShapeBtn.SetPointList(Value: TStringList);
begin
  FPointList.Assign(Value);
  RecreateWnd;
end;

procedure TfcCustomShapeBtn.SetShape(Value: TfcButtonShape);
begin
  if FShape <> Value then
  begin
    FShape := Value;
    Recreatewnd;

    // Ensures that the control's rectangle gets invalidated even in a transparent button group
    if (Parent <> nil) and fcIsClass(Parent.ClassType, 'TfcCustomButtonGroup') then
      fcParentInvalidate(Parent, True);
  end
end;

// Given a set of points will rotate the points to the given orientation.
// Method assumes points passed in are oriented up

procedure TfcCustomShapeBtn.SetPointToOrientation(Points: PFCPolygonPoints;
  NumPoints: Integer; Orientation: TfcShapeOrientation; Size: TSize);
var i: Integer;
    RepeatInc, RepCount: Integer;
begin
  RepCount := 0;
  case Orientation of
    soLeft: RepCount := 3;
    soRight: RepCount := 1;
    soUp: RepCount := 0;
    soDown: RepCount := 2;
  end;
  for RepeatInc := 1 to RepCount do
    for i := 0 to NumPoints - 1 do with Points[i] do
      Points[i] := Point(Size.cx - (y * Size.cx div Size.cy), (x * Size.cy div Size.cx));
end;

procedure SetupPointList(var PointList: PfcPolygonPoints; NumPoints: Integer);
begin
  PointList := AllocMem((NumPoints + 1) * SizeOf(TPoint));
  FillChar(PointList^, (NumPoints + 1) * SizeOf(TPoint), 0);
end;

function GetNum(Num: Integer): Integer;
begin
  result := Num;
end;

function TfcCustomShapeBtn.GetCustomPoints(var Points: PFCPolygonPoints; Size: TSize): Integer;
var i: Integer;
    CurPoint, x, y: string;
begin
  result := PointList.Count;
  if result <= 2 then
  begin
    result := 0;
    Exit;
  end;

  SetupPointList(Points, result);

  try
    for i := 0 to result - 1 do
    begin
      CurPoint := UpperCase(PointList[i]);
      if Pos(',', CurPoint) = 0 then
        raise EInvalidOperation.Create('Invalid Custom Points Format.  X and Y ' +
          'Coordinates must be separated by a comma and space.');
      CurPoint := fcReplace(CurPoint, ',', ', ');
      CurPoint := fcReplace(CurPoint, ',  ', ', ');
      CurPoint := fcReplace(CurPoint, 'WIDTH', InttoStr(Size.cx));
      CurPoint := fcReplace(CurPoint, 'HEIGHT', InttoStr(Size.cy));
      x := fcGetToken(CurPoint, ', ', 0);
      y := fcGetToken(CurPoint, ', ', 1);
      with Point(TfcEvaluator.Evaluate(x), TfcEvaluator.Evaluate(y)) do
        Points[i] := Point(x, y);
    end;
  except
    FreeMem(Points);
    Points := nil;
    FShape := bsRect;
    raise;
  end;
end;

function TfcCustomShapeBtn.GetStarPoints(var Points: PFCPolygonPoints; Size: TSize): Integer;
var BottomOff: Integer;
    BaseTri, SideTri, HeightTri: Integer;
    Side: Integer;
begin
  result := 10;
  SetupPointList(Points, result);

  Side := Trunc(Size.cy / Cos(DegToRad(18)));
  SideTri := Trunc(Side / (2 + 2 * Sin(DegToRad(18))));
  BaseTri := Side - 2 * SideTri;
  HeightTri := Trunc(SideTri * Cos(DegToRad(18)));
  BottomOff := Trunc(Tan(DegToRad(18)) * Size.cy);
  Points[GetNum(0)] := Point(Size.cx div 2, 0);
  Points[GetNum(1)] := Point(Size.cx div 2 + BaseTri div 2, HeightTri);
  Points[GetNum(2)] := Point(Size.cx, Points[GetNum(1)].y);
  Points[GetNum(3)] := Point(Points[GetNum(1)].x + Trunc(Sin(DegToRad(18)) * BaseTri),
                     Points[GetNum(1)].y + Trunc(Cos(DegToRad(18)) * BaseTri));
  Points[GetNum(4)] := Point(Size.cx div 2 + BottomOff, Size.cy);
  Points[GetNum(5)] := Point(Size.cx div 2, Size.cy - Trunc(Sin(DegToRad(36)) * SideTri));
  Points[GetNum(6)] := Point(Size.cx div 2 - BottomOff, Size.cy);
  Points[GetNum(7)] := Point(Size.cx - Points[GetNum(3)].x, Points[GetNum(3)].y);
  Points[GetNum(8)] := Point(0, Points[GetNum(2)].y);
  Points[GetNum(9)] := Point(Size.cx - Points[GetNum(1)].x, Points[GetNum(1)].y);
end;

function TfcCustomShapeBtn.GetPolygonPoints(var Points: PfcPolygonPoints): Integer;
var Size: TSize;
begin
  result := 0;
  Size := fcSize(Width - 1, Height - 1);
  case Shape of
    bsTriangle: begin
      result := 3;
      SetupPointList(Points, result);
      // Default Up, SetPointToOrientation adjusts for orientation
      Points[GetNum(0)] := Point(Size.cx div 2, 0);
      Points[GetNum(1)] := Point(Size.cx, Size.cy);
      Points[GetNum(2)] := Point(0, Size.cy);
    end;