xpbuttonclass.pas

XP_Buttons for delphi7 绝对精典的按钮控件

//==============================================================================
//  XPButtonClass.pas
//  Author : SteedSky
//  Modify Data : 2003.08.20
//  E-Mail : [e-mail]
//==============================================================================
unit XPButtonClass;

interface

uses Windows, Graphics, Classes, Controls, Messages;

const
  //Buttons States
  XP_SELETED = 0 ;
  XP_FOCUSED = 1 ;
  XP_DEFAULT = 2 ;
  XP_CLICKED = 3 ;

{$IFNDEF DFS_COMPILER_4_UP}
const
  MSH_MOUSEWHEEL = 'MSWHEEL_ROLLMSG';
  WM_MOUSEWHEEL    = $020A;
  WHEEL_DELTA      = 120;
  WHEEL_PAGESCROLL = MAXDWORD;

  SM_MOUSEWHEELPRESENT    = 75;
  SPI_GETWHEELSCROLLLINES = 104;
  SPI_SETWHEELSCROLLLINES = 105;

type
  TWMMouseWheel = record
    Msg: Cardinal;
    Keys: Word;
    Delta: Word;
    case Integer of
      0: (
        XPos: Smallint;
        YPos: Smallint);
      1: (
        Pos: TSmallPoint;
        Result: Longint);
  end;
{$ENDIF}

type
  TXPStyleColor = record //XPButton Style Colors
    BorderColor,
    RectPointColor,
    RectTColor,
    RectBColor,
    STBorderColor1,
    STBorderColor2,
    SBBorderColor1,
    SBBorderColor2,
    FTBorderColor1,
    FTBorderColor2,
    FBBorderColor1,
    FBBorderColor2,
    DTBorderColor1,
    DTBorderColor2,
    DBBorderColor1,
    DBBorderColor2,
    DBBorderColor3  : TColor ;
  end;

type
  TButtonKind = (bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo, bkClose, bkAbort, bkRetry, bkIgnore, bkAll,
                   bkOpen, bkNew, bkCopy, bkCut, bkEdit, bkDelete, bkPaste, bkFind, bkUndo, bkRedo, bkSave,
                   bkCheck, bkPrinter, bkExit, bkHelps, bkAbout, bkCalculate, bkSearch, bkInformation,
                   bkPassWord, bkStart, bkPrevious, bkNext, bkEnd, bkQuestion, bkSaveto, bkChart, bkDesign,
                   bkPreview, bkRefresh, bkPropertiy);
  TButtonStyle = (bsStandard, bsGradient, bsXPBlue, bsXPArgent, bsXPGreen);
  TButtonLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);
  TButtonState = (bsUp, bsDisabled, bsDown);
  TGradientType = (gtLeftRight, gtTopBottom);
  TScrollType = (up, down);
  TColorCalcType = (lighten, darken);
  TArrowPos = (NE, NW, SE, SW);
  TNumGlyphs = 1..4;
  TAdvColors = 0..100;
  TTransparentMode = (tmAlways, tmNotFocused, tmNone);

//Function
function GetGradColor(const ARect: TRect; const StartColor, EndColor: TColor; const Counter: Integer): TColor;
function CreateDisabledBitmap (FOriginal: TBitmap; OutlineColor, BackColor, HighlightColor, ShadowColor: TColor; DrawHighlight: Boolean): TBitmap;
function GetFontMetrics (Font: TFont): TTextMetric;
function GetFontHeight (Font: TFont): Integer;
function RectInRect (R1, R2: TRect): Boolean;


//Procedure
procedure DrawGradientColor(ACanvas: TCanvas; ARect: TRect; const StartColor, EndColor: TColor);
procedure DrawXPStyleBorder(Canvas: TCanvas; ARect:TRect; const TBColor1, TBColor2, BBColor1, BBColor2, BBColor3: TColor);
procedure DrawXpStyle(Canvas: TCanvas; ARect:TRect; FState: TButtonState);
procedure SetXPStyleColors(ButtonStyle: TButtonStyle);

procedure CalcButtonLayout (Canvas: TCanvas; const Client: TRect; const Offset: TPoint; Layout: TButtonLayout; Spacing, Margin: Integer; FGlyph: TBitmap; FNumGlyphs: Integer; const Caption: string; var TextBounds: TRect; var GlyphPos: TPoint);
procedure DrawTransparentBmp (Cnv: TCanvas; x, y: Integer; Bmp: TBitmap; clTransparent: TColor);
procedure DrawParentImage (Control: TControl; Dest: TCanvas);
procedure Frame3DBorder (Canvas: TCanvas; Rect: TRect; TopColor, BottomColor: TColor; Width: Integer);

var
  XPButtonColor : TXPStyleColor ;

implementation

{$R XpButtons.RES}

//==============================================================================
//Procedure
//==============================================================================
procedure DrawGradientColor(ACanvas: TCanvas; ARect: TRect; const StartColor, EndColor: TColor);
var
  I : Integer;
  FRect : TRect ;
begin
  Inc(ARect.Left,1);
  Inc(ARect.Top,1);
  Dec(ARect.Right,1);
  Dec(ARect.Bottom,1);
  FRect := ARect ;
  for I := 1  to ARect.Bottom - ARect.Top do begin
      ACanvas.Brush.Color := GetGradColor(ARect, StartColor, EndColor, I);
      ACanvas.FillRect(FRect);

      FRect.Top := FRect.Top + 1;
      FRect.Bottom := FRect.Top + 1;
 end;
end;

procedure Frame3DBorder (Canvas: TCanvas; Rect: TRect; TopColor, BottomColor: TColor; Width: Integer);

  procedure DoRect;
  var
    TopRight, BottomLeft: TPoint;
  begin
    with Canvas, Rect do
    begin
      TopRight.X := Right;
      TopRight.Y := Top;
      BottomLeft.X := Left;
      BottomLeft.Y := Bottom;
      Pen.Color := TopColor;
      PolyLine([BottomLeft, TopLeft, TopRight]);
      Pen.Color := BottomColor;
      Dec(BottomLeft.X);
      PolyLine([TopRight, BottomRight, BottomLeft]);
    end;
  end;
begin
  Canvas.Pen.Width := 1;
  Dec(Rect.Bottom); Dec(Rect.Right);
  while Width > 0 do
  begin
    Dec(Width);
    DoRect;
    InflateRect(Rect, -1, -1);
  end;
  Inc(Rect.Bottom); Inc(Rect.Right);
end;

procedure DrawTransparentBmp (Cnv: TCanvas; x, y: Integer; Bmp: TBitmap; clTransparent: TColor);
var
  bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap;
  oldcol: Longint;
begin
  bmpAND := TBitmap.Create;
  bmpINVAND := TBitmap.Create;
  bmpXOR := TBitmap.Create;
  bmpTarget := TBitmap.Create;
  try
    bmpAND.Width := Bmp.Width;
    bmpAND.Height := Bmp.Height;
    bmpAND.Monochrome := True;
    oldcol := SetBkColor(Bmp.Canvas.Handle, ColorToRGB(clTransparent));
    BitBlt(bmpAND.Canvas.Handle, 0, 0, Bmp.Width ,Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);
    SetBkColor(Bmp.Canvas.Handle, oldcol);

    bmpINVAND.Width := Bmp.Width;
    bmpINVAND.Height := Bmp.Height;
    bmpINVAND.Monochrome := True;
    BitBlt(bmpINVAND.Canvas.Handle, 0, 0,Bmp.Width,Bmp.Height, bmpAND.Canvas.Handle, 0, 0, NOTSRCCOPY);

    bmpXOR.Width := Bmp.Width;
    bmpXOR.Height := Bmp.Height;
    BitBlt(bmpXOR.Canvas.Handle, 0, 0,Bmp.Width,Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);
    BitBlt(bmpXOR.Canvas.Handle, 0, 0,Bmp.Width,Bmp.Height, bmpINVAND.Canvas.Handle, 0, 0, SRCAND);

    bmpTarget.Width := Bmp.Width;
    bmpTarget.Height := Bmp.Height;
    BitBlt(bmpTarget.Canvas.Handle, 0, 0,Bmp.Width,Bmp.Height, Cnv.Handle, x, y, SRCCOPY);
    BitBlt(bmpTarget.Canvas.Handle, 0, 0,Bmp.Width,Bmp.Height, bmpAND.Canvas.Handle, 0, 0, SRCAND);
    BitBlt(bmpTarget.Canvas.Handle, 0, 0,Bmp.Width,Bmp.Height, bmpXOR.Canvas.Handle, 0, 0, SRCINVERT);

    BitBlt(Cnv.Handle, x, y, Bmp.Width, Bmp.Height, bmpTarget.Canvas.Handle, 0, 0, SRCCOPY);
  finally
    bmpXOR.Free;
    bmpAND.Free;
    bmpINVAND.Free;
    bmpTarget.Free;
  end;
end;

procedure DrawParentImage(Control: TControl; Dest: TCanvas);
var
  SaveIndex: Integer;
  DC: HDC;
  Position: TPoint;
begin
  with Control do
  begin
    if Parent = nil then
      Exit;
    DC := Dest.Handle;
    SaveIndex := SaveDC(DC);
    {$IFDEF DFS_COMPILER_2}
    GetViewportOrgEx(DC, @Position);
    {$ELSE}
    GetViewportOrgEx(DC, Position);
    {$ENDIF}
    SetViewportOrgEx(DC, Position.X - Left, Position.Y - Top, nil);
    IntersectClipRect(DC, 0, 0, Parent.ClientWidth, Parent.ClientHeight);
    Parent.Perform(WM_ERASEBKGND, DC, 0);
    Parent.Perform(WM_PAINT, DC, 0);
    RestoreDC(DC, SaveIndex);
  end;
end;

procedure CalcButtonLayout (Canvas: TCanvas; const Client: TRect; const Offset: TPoint; Layout: TButtonLayout;
  Spacing, Margin: Integer; FGlyph: TBitmap; FNumGlyphs: Integer;
  const Caption: string; var TextBounds: TRect; var GlyphPos: TPoint);
var
  TextPos: TPoint;
  ClientSize, GlyphSize, TextSize: TPoint;
  TotalSize: TPoint;
begin
  // calculate the item sizes
  ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top);

  if FGlyph <> nil then
    GlyphSize := Point(FGlyph.Width div FNumGlyphs, FGlyph.Height)
  else
    GlyphSize := Point(0, 0);

  if Length(Caption) > 0 then
    begin
      TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
      DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CALCRECT or DT_SINGLELINE);
      TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom - TextBounds.Top);
    end
  else
    begin
      TextBounds := Rect(0, 0, 0, 0);
      TextSize := Point(0, 0);
    end;

  // If the layout has the glyph on the right or the left, then both the
  // text and the glyph are centered vertically.  If the glyph is on the top
  // or the bottom, then both the text and the glyph are centered horizontally.
  if Layout in [blGlyphLeft, blGlyphRight] then
  begin
    GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
    TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
  end
  else
  begin
    GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;
    TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
  end;

  // if there is no text or no bitmap, then Spacing is irrelevant
  if (TextSize.X = 0) or (GlyphSize.X = 0) then
    Spacing := 0;

  // adjust Margin and Spacing
  if Margin = -1 then
  begin
    if Spacing = -1 then
    begin
      TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
      if Layout in [blGlyphLeft, blGlyphRight] then
        Margin := (ClientSize.X - TotalSize.X) div 3
      else
        Margin := (ClientSize.Y - TotalSize.Y) div 3;
      Spacing := Margin;
    end
    else
    begin
      TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y + Spacing + TextSize.Y);
      if Layout in [blGlyphLeft, blGlyphRight] then
        Margin := (ClientSize.X - TotalSize.X + 1) div 2
      else
        Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
    end;
  end
  else
  begin