xpgroupbox.pas

非常好的xp界面控件

unit xpGroupBox;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, xpGraphUtil, xpReg, xpCtrlStyle;

type
  TxpGroupBoxBGStyle = (bgsNone, bgsGradient, bgsTileImage, bgsStrechImage);

  TxpGroupBox = class;

  //////////////////////////////////////////////////////////////////////////////
  TxpGroupBoxStyle = class (TxpControlStyle)
  private
    FxpGroupBox : TxpGroupBox;
    FBorderColor : TColor;
    FRoundedCorners : TRoundedCorners;
    FBGStyle : TxpGroupBoxBGStyle;
    FGradientStartColor : TColor;
    FGradientEndColor : TColor;
    FGradientFillDir : TFillDirection;
    FBGImage : TBitmap;

  protected
    procedure SetActive (AValue : Boolean); override;
    procedure SetBorderColor (AValue : TColor);
    procedure SetRoundedCorners (AValue : TRoundedCorners);
    procedure SetBGStyle (AValue : TxpGroupBoxBGStyle);
    procedure SetBGImage (AValue : TBitmap);
    procedure SetGradientStartColor (AValue : TColor);
    procedure SetGradientEndColor (AValue : TColor);
    procedure SetGradientFillDir (AValue : TFillDirection);

    function GetWindowShape (ARounded : TRoundedCorners) : hRgn;
    procedure SetShape (ARounded : TRoundedCorners);
  public
    constructor Create (AOwner : TxpGroupBox); 
    destructor  Destroy; override;
  published
    property BorderColor : TColor read FBorderColor write SetBorderColor;
    property RoundedCorners : TRoundedCorners read FRoundedCorners write SetRoundedCorners;
    property BGStyle : TxpGroupBoxBGStyle read FBGSTyle write SetBGStyle;
    property GradientStartColor : TColor read FGradientStartColor write SetGradientStartColor;
    property GradientEndColor : TColor read FGradientEndColor write SetGradientEndColor;
    property GradientFillDir : TFillDirection read FGradientFillDir write SetGradientFillDir;
    property BGImage : TBitmap read FBGImage write SetBGImage;
  end;

  //////////////////////////////////////////////////////////////////////////////
  TxpGroupBox = class(TGroupBox)
  private
    { Private declarations }
    FCanvas : TControlCanvas;
    FxpStyle : TxpGroupBoxStyle;

  protected
    { Protected declarations }
    procedure Paint; override;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMSize (var Message : TMessage); message WM_SIZE;
    procedure WMTextChanged (var Message : TMessage); message CM_TEXTCHANGED;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy;
  published
    { Published declarations }
    property XPStyle : TxpGroupBoxStyle read FxpStyle write FxpStyle;
  end;

procedure Register;

implementation

const
  cCornerRadius : Integer = 10;


////////////////////////////////////////////////////////////////////////////////
constructor TxpGroupBoxStyle.Create (AOwner : TxpGroupBox);
begin
  inherited Create;
  FxpGroupBox := AOwner;
  FBorderColor := clSilver;
  RoundedCorners := [rcTopLeft, rcTopRight, rcBottomLeft, rcBottomRight];

  FBGImage := TBitmap.Create;
  FBGStyle := bgsNone;
  FGradientStartColor := clWhite;
  FGradientEndColor := clSilver;
  FGradientFillDir := fdTopToBottom;
end;

destructor  TxpGroupBoxStyle.Destroy;
begin
  try FBGImage.Free; except end;
  inherited;
end;

procedure TxpGroupBoxStyle.SetActive (AValue : Boolean);
begin
  inherited;
  FxpGroupBox.Invalidate;
  FxpGroupBox.RecreateWnd;
end;

procedure TxpGroupBoxStyle.SetBorderColor (AValue : TColor);
begin
  if FBorderColor <> AValue then
  begin
    FBorderColor := AValue;
    FxpGroupBox.Invalidate;
  end;
end;


function TxpGroupBoxStyle.GetWindowShape (ARounded : TRoundedCorners) : hRgn;
var
  WinRgn : hRgn;
  WinRgn1 : hRgn;
  WinRgn2 : hRgn;
  ShadowRgn : hRgn;
  Rectn : TRect;
  RTop, RBottom : Integer;
  AWidth, AHeight : Integer;
  ATextHeight : Integer;
begin
  WinRgn := 0;
  GetWindowRect (FxpGroupBox.Handle, Rectn);
  OffsetRect (Rectn, -Rectn.Left, -Rectn.Top);

  AWidth := FxpGroupBox.Width;
  AHeight := FxpGroupBox.Height;

  FxpGroupBox.Canvas.Font := FxpGroupBox.Font;
  ATextHeight := FxpGroupBox.Canvas.TextHeight('0') div 2;

  if ARounded <> [] then
  begin
    RTop := 0;
    RBottom := AHeight;
    if (rcTopLeft in ARounded) or (rcTopRight in ARounded) then RTop := cCornerRadius div 2;
    if (rcBottomLeft in ARounded) or (rcBottomRight in ARounded) then RBottom := AHeight - cCornerRadius div 2;

    WinRgn := CreateRectRgn (0, RTop+ATextHeight, AWidth, RBottom);

    //Create topleft rounded corner
    if  rcTopLeft in ARounded then
    begin
      WinRgn1 := CreateRectRgn (cCornerRadius div 2, cCornerRadius div 2+ATextHeight, cCornerRadius, cCornerRadius+ATextHeight);
      WinRgn2 := CreateEllipticRgn (0,ATextHeight,cCornerRadius+1,cCornerRadius+1+ATextHeight);
      CombineRgn (WinRgn1, WinRgn1, WinRgn2, RGN_OR);
      CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);
      DeleteObject(WinRgn1);
      DeleteObject(WinRgn2);

      //Create result region
      if rcTopRight in ARounded then
      begin
        WinRgn1 := CreateRectRgn (cCornerRadius div 2, ATextHeight, AWidth - cCornerRadius div 2, cCornerRadius+ATextHeight);
        CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);
      end
      else
      begin
        WinRgn1 := CreateRectRgn (cCornerRadius div 2, ATextHeight, AWidth, cCornerRadius+ATextHeight);
        CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);
      end;
      DeleteObject(WinRgn1);
    end;

    //Create topright rounded corner
    if  rcTopRight in ARounded then
    begin
      WinRgn1 := CreateRectRgn (AWidth - cCornerRadius, ATextHeight, AWidth - cCornerRadius div 2, cCornerRadius+ATextHeight);
      WinRgn2 := CreateEllipticRgn (AWidth - cCornerRadius + 1, ATextHeight, AWidth+1, cCornerRadius+ATextHeight);
      CombineRgn (WinRgn1, WinRgn1, WinRgn2, RGN_OR);
      CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);
      DeleteObject(WinRgn1);
      DeleteObject(WinRgn2);

      //Create result region
      if rcTopLeft in ARounded then
      begin
        WinRgn1 := CreateRectRgn (cCornerRadius div 2, ATextHeight, AWidth - cCornerRadius div 2, cCornerRadius+ATextHeight);
        CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);
      end
      else
      begin
        WinRgn1 := CreateRectRgn (0, ATextHeight, AWidth - cCornerRadius, cCornerRadius+ATextHeight);
        CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);
      end;
      DeleteObject (WinRgn1);
    end;

    //Create bottomleft rounded corner
    if  rcBottomLeft in ARounded then
    begin
      WinRgn1 := CreateRectRgn (cCornerRadius div 2, AHeight - cCornerRadius, cCornerRadius, AHeight - cCornerRadius div 2);
      WinRgn2 := CreateEllipticRgn (0, AHeight - cCornerRadius, cCornerRadius,AHeight+1);
      CombineRgn (WinRgn1, WinRgn1, WinRgn2, RGN_OR);
      CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);
      DeleteObject(WinRgn1);
      DeleteObject(WinRgn2);

      //Create result region
      if rcBottomRight in ARounded then
      begin
        WinRgn1 := CreateRectRgn (cCornerRadius div 2, AHeight - cCornerRadius div 2, AWidth - cCornerRadius div 2, AHeight);
        CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);
      end
      else
      begin
        WinRgn1 := CreateRectRgn (cCornerRadius div 2, AHeight - cCornerRadius div 2, AWidth, AHeight);
        CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);
      end;
      DeleteObject (WinRgn1);
    end;

    //Create bottomright rounded corner
    if  rcBottomRight in ARounded then
    begin
      WinRgn1 := CreateRectRgn (AWidth - cCornerRadius, AHeight - cCornerRadius,
        AWidth - cCornerRadius div 2, AHeight);
      WinRgn2 := CreateEllipticRgn (AWidth - cCornerRadius + 1, AHeight-cCornerRadius+1, AWidth+1, AHeight+1);
      CombineRgn (WinRgn1, WinRgn1, WinRgn2, RGN_OR);
      CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);
      DeleteObject(WinRgn1);
      DeleteObject(WinRgn2);

      //Create result region
      if rcBottomLeft in ARounded then
      begin
        WinRgn1 := CreateRectRgn (cCornerRadius div 2, AHeight - cCornerRadius div 2, AWidth - cCornerRadius div 2+1, AHeight);
        CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR)
      end
      else
      begin
        WinRgn1 := CreateRectRgn (0, AHeight - cCornerRadius div 2, AWidth - cCornerRadius div 2+1, AHeight);
        CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);
      end;
      DeleteObject (WinRgn1);
    end;

  end
  else
    WinRgn := CreateRectRgn (0, ATextHeight, AWidth, AHeight);

  //Add Box for caption;
  ATextHeight := FxpGroupBox.Canvas.TextHeight('0') div 2 - 1;
  Rectn := Rect(8, 0, 0, ATextHeight * 2);
  DrawText(FxpGroupBox.Canvas.Handle, PChar(FxpGroupBox.Text), Length(FxpGroupBox.Text),
    Rectn, DT_LEFT or DT_SINGLELINE or DT_CALCRECT);

  //InflateRect (Rectn, 1, 1);
  WinRgn1 := CreateRectRgn (Rectn.Left, Rectn.Top, Rectn.Right, Rectn.Bottom);
  CombineRgn (WinRgn, WinRgn, WinRgn1, RGN_OR);

  DeleteObject (WinRgn1);

  Result := WinRgn;
end;

procedure TxpGroupBoxStyle.SetShape (ARounded : TRoundedCorners);
var
  WinRgn : hRgn;
begin
  WinRgn := 0;
  //Delete old window region
  GetWindowRgn (FxpGroupBox.Handle, WinRgn);
  DeleteObject(WinRgn);

  WinRgn := GetWindowShape (ARounded);

  SetWindowRgn (FxpGroupBox.Handle, WinRgn, true);
end;

procedure TxpGroupBoxStyle.SetRoundedCorners (AValue : TRoundedCorners);
begin
  if FRoundedCorners <> AValue then
  begin
    FRoundedCorners := AValue;
    if Active and not (csDesigning in FxpGroupBox.ComponentState) and Assigned (FxpGroupBox.Parent) then
      SetShape (RoundedCorners);
  end;
end;

procedure TxpGroupBoxStyle.SetBGStyle (AValue : TxpGroupBoxBGStyle);
begin
  if FBGStyle <> AValue then
  begin
    FBGStyle := AValue;
    FxpGroupBox.Invalidate;
  end;
end;

procedure TxpGroupBoxStyle.SetGradientStartColor (AValue : TColor);
begin
  if FGradientStartColor <> AValue then
  begin
    FGradientStartColor := AValue;
    FxpGroupBox.Invalidate;
  end;
end;

procedure TxpGroupBoxStyle.SetGradientEndColor (AValue : TColor);
begin
  if FGradientEndColor <> AValue then
  begin
    FGradientEndColor := AValue;
    FxpGroupBox.Invalidate;
  end;
end;

procedure TxpGroupBoxStyle.SetGradientFillDir (AValue : TFillDirection);
begin
  if FGradientFillDir <> AValue then
  begin
    FGradientFillDir := AValue;
    FxpGroupBox.Invalidate;
  end;
end;


procedure TxpGroupBoxStyle.SetBGImage (AValue : TBitmap);
begin
  FBGImage.FreeImage;
  FBGImage.Assign (AValue);
  if (FBGImage.Empty) and (FBGStyle in [bgsTileImage, bgsStrechImage]) then
    FBGStyle := bgsNone;
  FxpGroupBox.Invalidate;
end;

////////////////////////////////////////////////////////////////////////////////
constructor TxpGroupBox.Create(AOwner: TComponent);
begin
  inherited;// Create (AOwner);
  FxpStyle := TxpGroupBoxStyle.Create (Self);
  Font.Color := clBlue;
  FCanvas := TControlCanvas.Create;
end;

destructor  TxpGroupBox.Destroy;
begin
  try FxpStyle.Free except end;
  try FCanvas.Free except end;
  inherited;
end;

procedure TxpGroupBox.Paint;
var
  H: Integer;
  R: TRect;
  WinRgn : hRgn;
begin
  if not FxpStyle.Active then
  begin
    inherited;
    Exit;
  end;

  with Canvas do
  begin
    Font := Self.Font;
    H := TextHeight('0');
    R := Rect(0, H div 2 - 1, Width, Height);
    Pen.Color := FxpStyle.FBorderColor;
    Brush.Color := FxpStyle.FBorderColor;
    WinRgn := FxpStyle.GetWindowShape (FxpStyle.RoundedCorners);
    FrameRgn (Handle, WinRgn, Brush.Handle, 1, 1);
    DeleteObject (WinRgn);
    if Text <> '' then
    begin
      R := Rect(8, 0, 0, H);
      DrawText(Handle, PChar(Text), Length(Text), R, DT_LEFT or DT_SINGLELINE or
        DT_CALCRECT);
      Inc (R.Bottom, 1);
      //FrameRect (R);
      Brush.Color := Color;
      //Brush.Style := bsClear;
      DrawText(Handle, PChar(Text), Length(Text), R, DT_LEFT or DT_SINGLELINE);
    end;
  end;
end;

procedure TxpGroupBox.WMEraseBkgnd(var Message: TWMEraseBkgnd);
var
  DC : hDC;
  PS : TPaintStruct;
  ARect : TRect;
begin
  if not FxpStyle.Active then
  begin
    inherited;
    Exit;
  end;

  if Message.DC = 0 then DC := BeginPaint(Handle, PS) else DC := Message.DC;
  try
    FCanvas.Handle := DC;
    if ParentColor then FCanvas.Brush.Color := Parent.Brush.Color
      else FCanvas.Brush.Color := Color;
    FCanvas.FillRect (ClientRect);

    FCanvas.Font := Self.Font;

    ARect := Rect(0, 2{FCanvas.TextHeight('0') div 2 - 1}, Width, Height);
    InflateRect (ARect, -1, -1);

    case FxpStyle.BGStyle of
      bgsNone: begin
                 FCanvas.Brush.Color := Color;
                 FCanvas.FillRect (ARect);
               end;
      bgsGradient:
               begin
                 GradientFillRect (FCanvas, ARect, FxpStyle.GradientStartColor, FxpStyle.GradientEndColor,
                   FxpStyle.GradientFillDir, 60);
               end;
      bgsTileImage:
               if not FxpStyle.BGImage.Empty then
               begin
                 TileImage(FCanvas, ARect, FxpStyle.BGImage);
               end
               else
               begin
                 FCanvas.Brush.Color := Color;
                 FCanvas.FillRect (ARect);
               end;
      bgsStrechImage:
               if not FxpStyle.BGImage.Empty then
               begin
                 FCanvas.StretchDraw (ARect, FxpStyle.BGImage);
               end
               else
               begin
                 FCanvas.Brush.Color := Color;
                 FCanvas.FillRect (ARect);
               end;
    end;
  finally
    if Message.DC = 0 then EndPaint(Handle, PS);
  end;

end;

procedure TxpGroupBox.WMSize (var Message : TMessage);
begin
  inherited;
  if FxpStyle.Active then FxpStyle.SetShape (FxpStyle.RoundedCorners);
end;

procedure TxpGroupBox.WMTextChanged (var Message : TMessage);
begin
  inherited;
  if (FxpStyle.Active) and (Assigned(Parent)) then FxpStyle.SetShape (FxpStyle.RoundedCorners);
end;


procedure Register;
begin
  RegisterComponents('XP Controls', [TxpGroupBox]);
end;

end.