Chip 2001 December/Chip_2001-12_cd1.bin/zkuste/delphi/kolekce/d345/JWTOOL.ZIP/jwtool/JwWrpBtn.pas

Pascal/Delphi Source File | 2001-09-29 | 22.6 KB | 844 lines

unit JwWrpbtn;

{
        **   VERSION History   **
   Version     Date     Notes
    v1.00  - 01APR99    Original Release
}

{
     One problem has always been that you have too much information that
you want to place on a button, but not enough room to do so.  What this
component does is simply take a TLabel (yes, that's right, a TLabel) and
redo the painting so that it draws to look just like a button.  Also
since we want a button effect, it has different procedures painting procedures
if the mouse is down or up.  Remember:  This does offer the benefit of
"borrowing" it's owner's canvas to draw itself, and therefore doesn't take
as much memory.
     Borrowing a bit from the JwLabel, we're going to make this button rotatable,
and have a few "special effects."
    NOTE:  I have to admit that I borrowed some of the *ideas* to make the 3D effect
from the "Raize" components published in the Coriolis book on creating components,
however, it is not a DIRECT code-theft.

  Created By:
    Joseph Wilcock
    [e-mail]
    http://msnhomepages.talkcity.com/RedmondAve/coockoo/

}

interface

uses {$IFDEF WIN32} Windows, {$ELSE} WinProcs, WinTypes, {$ENDIF}
     Messages, SysUtils, Classes, Controls, Forms, Graphics, Stdctrls;

type
  TWButtonState = (bsUp, bsDisabled, bsDown, bsExclusive);
  TTextStyle = ( tsNone, tsRaised, tsRecessed, tsShadow );
  {TFontWeightOption = ( fwDontCare, fwThin, fwExtraLight, fwLight, fwNormal,
                    fwRegular, fwMedium}
  TFontCharSet = ( fcANSI, fcDEFAULT, fcSYMBOL, fsSHIFTJIS, fsOEM );
  TJwWrapButton = class(TLabel)
    private
      { Private fields of TJwWrapButton }

      { Private methods of TJwWrapButton }
        FTextStyle : TTextStyle;
        FShadowColor : TColor;
        FShadowDepth : Integer;
        {Special Font Information}
        FFontHeight: Integer;
        FFontWidth: Integer;
        FFontEscapement: Integer;
        FFontOrientation: Integer;
        FFontWeight: Integer;
        FFontItalic: Byte;
        FFontUnderline: Byte;
        FFontStrikeOut: Byte;
        FFontCharSet: Byte;
        FFontOutPrecision: Byte;
        FFontClipPrecision: Byte;
        FFontQuality: Byte;
        FFontPitchAndFamily: Byte;
        FFontFaceName: String;
        FOffsetX: Integer;
        FOffsetY: Integer;
        FCentered: Boolean;
        FAllowDown: Boolean;
        F3dFont: Boolean;
        FButtonFace: TColor;
        FHighLight: TColor;
        FButtonShadow: TColor;
        FWindowFrame: TColor;
        Procedure Set3DFont( Value: Boolean );
        Procedure SetFontHeight( Value: Integer );
        Procedure SetFontWidth( Value: Integer );
        Procedure SetFontEscapement( Value: Integer );
        Procedure SetFontOrientation( Value: Integer );
        Procedure SetFontWeight( Value: Integer );
        Procedure SetFontItalic( Value: Byte );
        Procedure SetFontUnderline( Value: Byte );
        Procedure SetFontStrikeOut( Value: Byte );
        Procedure SetFontCharSet( Value: Byte );
        Procedure SetFontOutPrecision( Value: Byte );
        Procedure SetFontClipPrecision( Value: Byte );
        Procedure SetFontQuality( Value: Byte );
        Procedure SetFontPitchAndFamily( Value: Byte );
        Procedure SetFontFaceName( Value: String );
        Procedure SetOffsetX( Value: Integer );
        Procedure SetOffsetY( Value: Integer );
        Procedure SetCentered( Value: Boolean );
        {*****************}
        procedure SetTextStyle( Value : TTextStyle );
        procedure SetShadowColor( Value : TColor );
        procedure SetShadowDepth( Value : Integer );
        procedure SetButtonFace( Value: TColor );
        procedure SetHightLight( Value: TColor );
        procedure SetButtonShadow( Value: TColor );
        procedure SetWindowFrame( Value: TColor );
        procedure WMSize(var Message: TWMSize); message WM_SIZE;
        function DrawButtonFace( const Client: TRect;
                                       IsDown: Boolean ): TRect;
    protected
      { Protected fields of TJwWrapButton }
        FState: TWButtonState;
        FBevelWidth: Integer;
        FBorderWidth: Integer;
        Procedure SetBevelWidth( Value: Integer );
        Procedure SetBorderWidth( Value: Integer );

      { Protected methods of TJwWrapButton }
        procedure Click; override;
        procedure Loaded; override;
        { Add code to make this a button }
        procedure Paint; override;
        procedure DoDrawText(var Rect: TRect; Flags: Word);
        procedure Draw3DText( R : TRect; Flags : Word );
        procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
        procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    public
      { Public fields and properties of TJwWrapButton }

      { Public methods of TJwWrapButton }
        constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;

    published
      { Published properties of TJwWrapButton }
        Property Use3dFont: Boolean
          Read F3DFont
          Write Set3DFont
          Default False;

        property BevelWidth: Integer
          Read FBevelWidth
          Write SetBevelWidth
          default 2;

        property BorderWidth: Integer
          Read FBorderWidth
          Write SetBorderWidth
          default 2;

        property ShadowColor : TColor
          read FShadowColor
          write SetShadowColor
          default clBtnShadow;

        property ShadowDepth : Integer
          read FShadowDepth
          write SetShadowDepth
          default 2;

        property TextStyle : TTextStyle
          read FTextStyle
          write SetTextStyle
          default tsRecessed;

        property FontHeight: Integer
          read FFontHeight
          write SetFontHeight
          default 10;

        property FontWidth: Integer
          read FFontWidth
          write SetFontWidth
          default 10;

        property FontEscapement: Integer
          read FFontEscapement
          write SetFontEscapement
          default 0;

        property FontOrientation: Integer
          read FFontOrientation
          write SetFontOrientation
          default 0;

        property FontWeight: Integer
          read FFontWeight
          write SetFontWeight
          default 100;

        property FontItalic: Byte
          read FFontItalic
          write SetFontItalic
          default 0;

        property FontUnderline: Byte
          read FFontUnderline
          write SetFontUnderline
          default 0;

        property FontStrikout: Byte
          read FFontStrikeOut
          write SetFontStrikeOut
          default 0;

        property FontCharSet: Byte
          read FFontCharSet
          write SetFontCharSet
          default 0;

        property FontOutPrecision: Byte
          read FFontOutPrecision
          write SetFontOutPrecision
          default 0;

        property FontClipPrecision: Byte
          read FFontClipPrecision
          write SetFontClipPrecision
          default 0;

        property FontQuality: Byte
          read FFontQuality
          write SetFontQuality
          default 0;

        property FontPitchAndFamily: Byte
          read FFontPitchAndFamily
          write SetFontPitchAndFamily
          default 0;

        property FontFaceName: String
          read FFontFaceName
          write SetFontFaceName;

        property OffsetX: Integer
          read FOffsetX
          write SetOffsetX
          default 0;

        property OffsetY: Integer
          read FOffsetY
          write SetOffsetY
          default 0;

        property Centered: Boolean
          read FCentered
          write SetCentered
          default False;

        property AllowDown: Boolean
          Read FAllowDown
          Write FAllowDown
          Default True;

        property ButtonFace: TColor
          Read FButtonFace
          Write SetButtonFace
          default clbtnFace;

        property HighLight: TColor
          Read FHighLight
          Write SetHightLight
          default clBtnHighlight;

        property ButtonShadow: TColor
          Read FButtonShadow
          Write SetButtonShadow
          default clBtnShadow;

        property WindowFrame: TColor
          Read FWindowFrame
          Write SetWindowFrame
          default clWindowFrame;

        Property Anchors;
        property OnClick;
        property OnDblClick;
        property OnDragDrop;
        property OnMouseDown;
        property OnMouseMove;
        property OnMouseUp;

  end;

procedure Register;



implementation

uses ExtCtrls;

procedure Register;
begin
     { Register TJwWrapButton with Standard as its
       default page on the Delphi component palette }
     RegisterComponents('JwTools', [TJwWrapButton]);
end;

{ Override OnClick handler from TLabel }
procedure TJwWrapButton.Click;
begin
     { Code to execute before activating click
       behavior of component's parent class }

     { Activate click behavior of parent }
     inherited Click;

     { Code to execute after click behavior
       of parent }

end;

constructor TJwWrapButton.Create(AOwner: TComponent);
begin
     { Call the Create method of the parent class }
     inherited Create(AOwner);

     FBevelwidth := 2;
     FBorderWidth := 2;
     FAllowDown := True;
     FTextStyle := tsRecessed;
     FShadowDepth := 2;
     FShadowColor := clBtnShadow;
     FFontOutPrecision := OUT_TT_PRECIS;
     FFontClipPrecision := CLIP_TT_ALWAYS;
     FFontPitchAndFamily := VARIABLE_PITCH or TMPF_TRUETYPE or FF_SWISS;
     FFontFaceName := 'Arial';
     FFontHeight := 20;
     FFontWeight := 100;
     FFontCharSet := DEFAULT_CHARSET;
     FCentered := False;
     F3DFont := False;

     FButtonFace := clBtnFace;
     FHighLight := clBtnHighLight;
     FButtonShadow := clBtnShadow;
     FWindowFrame := clWindowFrame;

     FState := bsUp;
     AutoSize := false;
     WordWrap := True;
     Self.Width := 60;
     Self.Height := 60;
end;

Procedure TJwWrapButton.Set3DFont( Value: Boolean );
begin
  if Value <> F3DFont then
    begin
      F3DFont := Value;
      InValidate;
    end;
end;

Procedure TJwWrapButton.SetBevelWidth( Value: Integer );
begin
  if Value <> FBevelWidth then
    begin
      FBevelWidth := Value;
      InValidate;
    end;
end;

Procedure TJwWrapButton.SetBorderWidth( Value: Integer );
begin
  if Value <> FBorderWidth then
    begin
      FBorderWidth := Value;
      InValidate;
    end;
end;

destructor TJwWrapButton.Destroy;
begin
  inherited Destroy;
end;

procedure TJwWrapButton.Loaded;
begin
  inherited Loaded;
end;

{ Add code to make this a button }
procedure TJwWrapButton.Paint;
const
  Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
  PaintRect: TRect;
  TextBounds: TRect;

begin

     { To change the appearance of the component, use the methods
       supplied by the component's Canvas property (which is of
       type TCanvas).  For example, }
  if not Enabled and not (csDesigning in ComponentState) then
  begin
    FState := bsDisabled;
    {FDragging := False;}
  end
  else if FState = bsDisabled then FState := bsUp;

  Canvas.Font := Self.Font;
  Canvas.Brush.Color := Self.Color;

  PaintRect := DrawButtonFace( Rect(0, 0, Width, Height), FState in [bsDown] );

  with Canvas do
  begin
    Brush.Color := Self.Color;
    Brush.Style := bsClear;

    if F3dFont then
      begin
        PaintRect := ClientRect;
        Draw3DText( PaintRect, (DT_EXPANDTABS or DT_WORDBREAK) or
           Alignments[Self.Alignment] );
      end
    else
      begin
        PaintRect.Top := FBevelWidth + FBorderWidth;
        PaintRect.Left := FBevelWidth + FBorderWidth;
        PaintRect.Bottom := Height - FBevelWidth - FBorderWidth;
        PaintRect.Right := Width - FBevelWidth - FBorderWidth;
        DoDrawText( PaintRect, (DT_EXPANDTABS or DT_WORDBREAK) or
           Alignments[Self.Alignment] );
      end;
  end;
end;

procedure TJwWrapButton.WMLButtonDown(var Message: TWMLButtonDown);
begin
  Inherited;
  if FAllowDown then
    begin
      FState := bsDown;
      Invalidate;
    end;
end;

procedure TJwWrapButton.WMLButtonUp(var Message: TWMLButtonUp);
begin
  Inherited;
  if FAllowDown then
    begin
      FState := bsUp;
      Invalidate;
    end;
end;

procedure TJwWrapButton.WMSize(var Message: TWMSize);
var
     W, H: Integer;
begin
     { Our Label will imitate a button, so we want to make
     sure that caption is painted in the right place.  Hopefully,
     this will allow it, but it may require overriding some other
     "autosize" features of the TLabel to work completly}

     if NOT( F3dFont ) then
       begin
         W := Width + ( ( FBorderWidth + FBevelWidth ) * 2 );
         H := Height + ( ( FBorderWidth + FBevelWidth ) * 2 );
       end
     else
       begin
         W := Width;
         H := Height;
       end;

     { Code to check and adjust W and H }

     { Update the component size if we adjusted W or H }
     if (W <> Width) or (H <> Height) then
        inherited SetBounds(Left, Top, W, H);

     { Code to update dimensions of any owned sub-components
       by reading their Height and Width properties and updating
       via their SetBounds methods }

     Message.Result := 0;
end;

procedure TJwWrapButton.DoDrawText(var Rect: TRect; Flags: Word);
var
  Text: array[0..255] of Char;
begin
  GetTextBuf(Text, SizeOf(Text));
  if (Flags and DT_CALCRECT <> 0) and ((Text[0] = #0) {or FShowAccelChar} and
    (Text[0] = '&') and (Text[1] = #0)) then StrCopy(Text, ' ');
  {if not FShowAccelChar then Flags := Flags or DT_NOPREFIX;}
  Canvas.Font := Font;
  if not Enabled then Canvas.Font.Color := clGrayText;
  DrawText(Canvas.Handle, Text, StrLen(Text), Rect, Flags);
end;

procedure TJwWrapButton.Draw3DText( R : TRect; Flags : Word );
var
  CaptionStz : array[ 0..255 ] of Char;
  TempRct : TRect;
  TmpWidth: Integer;
  ULColor : TColor;
  LRColor : TColor;
begin
  with Canvas do
    begin
      StrPCopy( CaptionStz, Caption );

      TmpWidth := TextWidth( Caption );

      if WordWrap then
        Flags := Flags or dt_WordBreak;

      if not ShowAccelChar then
        Flags := Flags or dt_NoPrefix;

      Font := Self.Font;

      FFontFaceName := Font.Name;

      Font.Handle := CreateFont(   FFontHeight,  {Height}
                                    FFontWidth,  {Width}
                               FFontEscapement,  {Escapement}
                              FFontOrientation,  {Orientation}
                                   FFontWeight,  {Weight}
                                   FFontItalic,  {Italic}
                                FFontUnderline,  {Underline}
                                FFontStrikeOut,  {StrikeOut}
                                  FFontCharSet,  {CharSet}
                             FFontOutPrecision,  {OutputPrecision}
                            FFontClipPrecision,  {ClipPrecision}
                                  FFontQuality,  {Quality}
                           FFontPitchAndFamily,  {PitchAndFamily}
                             @FFontFaceName[1] );{FaceName}



      if FTextStyle in [ tsRecessed, tsRaised ] then
        begin
          if FTextStyle = tsRaised then
            begin
              ULColor := clBtnHighlight;
              LRColor := clBtnShadow;
            end
          else
            begin
              ULColor := clBtnShadow;
              LRColor := clBtnHighlight;
            end;

          TempRct := R;
          OffsetRect( TempRct, 1, 1 );
          Font.Color := LRColor;
          {DrawText( Handle, CaptionStz, -1, TempRct, Flags );}
          if FCentered then
            TempRct.Left := TempRct.Left - ( TmpWidth div 2 );
          Textout( TempRct.Left+FOffsetX, TempRct.Top+FOffsetY, Caption );

          TempRct := R;
          OffsetRect( TempRct, -1, -1 );
          Canvas.Font.Color := ULColor;
          {DrawText( Handle, CaptionStz, -1, TempRct, Flags );}
          if FCentered then
            TempRct.Left := TempRct.Left - ( TmpWidth div 2 );
          Textout( TempRct.Left+FOffsetX, TempRct.Top+FOffsetY, Caption );
          Font.Color := Self.Font.Color;
          if not Enabled then
            Font.Color := clGrayText;
          Textout( TempRct.Left+FOffsetX, TempRct.Top+FOffsetY, Caption );
        end
      else if FTextStyle = tsShadow then
        begin
          TempRct := R;
          OffsetRect( TempRct, FShadowDepth, FShadowDepth );
          Font.Color := FShadowColor;
          {DrawText( Handle, CaptionStz, -1, TempRct, Flags );}
          if FCentered then
            TempRct.Left := TempRct.Left - ( TmpWidth div 2 );
          Textout( TempRct.Left+FOffsetX, TempRct.Top+FOffsetY, Caption );
          Font.Color := Self.Font.Color;
          if not Enabled then
            Font.Color := clGrayText;
          Textout( TempRct.Left+FOffsetX, TempRct.Top+FOffsetY, Caption );
        end
      else
        begin
          Font.Color := Self.Font.Color;
          if not Enabled then
            Font.Color := clGrayText;
          {DrawText( Handle, CaptionStz, -1, R, Flags );}
          if FCentered then
            TempRct.Left := TempRct.Left - ( TmpWidth div 2 );
          Textout( TempRct.Left+FOffsetX, TempRct.Top+FOffsetY, Caption );
        end;
    end;  {with Canvas}
end;

function TJwWrapButton.DrawButtonFace( const Client: TRect;
                                       IsDown: Boolean ): TRect;
var
  R: TRect;
begin
  R := Client;
  with Canvas do
  begin
    Brush.Style := bsSolid;
    FillRect(R);

    {Frame3D is an actual API function!  It will draw a 3-D-ish frame around
    a specific rectangle.  One for border, and another for the "bevel"}
    if IsDown then
    begin
      Frame3D( Canvas, R, FButtonShadow, FHighLight, FBorderWidth );
      Frame3D( Canvas, R, FWindowFrame, FButtonShadow, FBevelWidth );
    end
    else
    begin
      Frame3D( Canvas, R, FButtonShadow, FWindowFrame, FBorderWidth );
      Frame3D( Canvas, R, FHighLight, FButtonShadow, FBevelWidth );
    end;
  end;


  Result := Client;
  InflateRect(Result, -BevelWidth, -BevelWidth);
  if IsDown then OffsetRect(Result, FBevelWidth, FBevelWidth);
end;

Procedure TJwWrapButton.SetFontHeight( Value: Integer );
begin
  if Value <> FFontHeight then
    begin
      FFontHeight := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontWidth( Value: Integer );
begin
  if Value <> FFontWidth then
    begin
      FFontWidth := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontEscapement( Value: Integer );
begin
  if Value <> FFontEscapement then
    begin
      FFontEscapement := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontOrientation( Value: Integer );
begin
  if Value <> FFontOrientation then
    begin
      FFontOrientation := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontWeight( Value: Integer );
begin
  if Value <> FFontWeight then
    begin
      FFontWeight := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontItalic( Value: Byte );
begin
  if Value <> FFontItalic then
    begin
      FFontItalic := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontUnderline( Value: Byte );
begin
  if Value <> FFontUnderline then
    begin
      FFontUnderline := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontStrikeOut( Value: Byte );
begin
  if Value <> FFontStrikeOut then
    begin
      FFontStrikeOut := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontCharSet( Value: Byte );
begin
  if Value <> FFontCharSet then
    begin
      FFontCharSet := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontOutPrecision( Value: Byte );
begin
  if Value <> FFontOutPrecision then
    begin
      FFontOutPrecision := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontClipPrecision( Value: Byte );
begin
  if Value <> FFontClipPrecision then
    begin
      FFontClipPrecision := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontQuality( Value: Byte );
begin
  if Value <> FFontQuality then
    begin
      FFontQuality := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontPitchAndFamily( Value: Byte );
begin
  if Value <> FFontPitchAndFamily then
    begin
      FFontPitchAndFamily := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetFontFaceName( Value: String );
begin
  if Value <> FFontFaceName then
    begin
      FFontFaceName := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetOffsetX( Value: Integer );
begin
  if Value <> FOffsetX then
    begin
      FOffsetX := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetOffsetY( Value: Integer );
begin
  if Value <> FOffsetY then
    begin
      FOffsetY := Value;
      Invalidate;
    end;
end;

Procedure TJwWrapButton.SetCentered( Value: Boolean );
begin
  if Value <> FCentered then
    begin
      FCentered := Value;
      Invalidate;
    end;
end;


{**********************}

procedure TJwWrapButton.SetShadowColor( Value : TColor );
begin
  if Value <> FShadowColor then
  begin
    FShadowColor := Value;
    Invalidate;
  end;
end;

procedure TJwWrapButton.SetButtonFace( Value: TColor );
begin
  if Value <> FButtonFace then
  begin
    FButtonFace := Value;
    Invalidate;
  end;
end;

procedure TJwWrapButton.SetHightLight( Value: TColor );
begin
  if Value <> FHighLight then
  begin
    FHighLight := Value;
    Invalidate;
  end;
end;
procedure TJwWrapButton.SetButtonShadow( Value: TColor );
begin
  if Value <> FButtonShadow then
  begin
    FButtonShadow := Value;
    Invalidate;
  end;
end;
procedure TJwWrapButton.SetWindowFrame( Value: TColor );
begin
  if Value <> FWindowFrame then
  begin
    FWindowFrame := Value;
    Invalidate;
  end;
end;

procedure TJwWrapButton.SetShadowDepth( Value : Integer );
begin
  if Value <> FShadowDepth then
  begin
    FShadowDepth := Value;
    Invalidate;
  end;
end;


procedure TJwWrapButton.SetTextStyle( Value : TTextStyle );
begin
  if Value <> FTextStyle then
  begin
    FTextStyle := Value;
    Invalidate;
  end;
end;


end.