Chip 2002 March/Chip_2002-03_cd1.bin/zkuste/delphi/kolekce/d123456/SIMONS.ZIP/Units/OvalBtn.pas

Pascal/Delphi Source File | 2000-10-11 | 19.4 KB | 719 lines

unit OvalBtn;

{ TOvalButton (C)opyright 2000 Version 1.32
  Autor : Simon Reinhardt
  eMail : [e-mail]
  Internet : http://www.picsoft.de

  Die Komponente TOvalButton ist eine ovale SpeedButton-Komponente. Sie ist
  abgeleteitet von TGraphicControl und ist eine Weiterentwicklung der Komponente
  TRoundButton von Brendan Rempel, der so nett war, diese als Public Domain
  zu ver÷ffentlichen.

  Vielen Dank auch an Marco Lange <[e-mail]> fⁿr die Korrektur
  der OnMouseEnter- und OnMouseLeave-Ereignisse.

  Die Komponente TOvalButton ist Public Domain, das Urheberrecht liegt
  aber beim Autor. }

interface

{$I SRDefine.inc}

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

type
  TNumGlyphs = 0..4;
  TButtonLayout = (blGlyphBottom, blGlyphLeft, blGlyphRight, blGlyphTop);

  TOvalButton = class(TGraphicControl)
  private
    FColor,
    FColorHighlight,
    FColorShadow:      TColor;
    FDown,IsDown,
    FFlat:             boolean;
    FFont:             TFont;
    FGlyph:            TBitmap;
    FGroupIndex:       integer;
    FLayout:           TButtonLayout;
    FMargin:           integer;
    FNumGlyphs:        TNumGlyphs;
    FSpacing,
    FState:            integer;
    FTransparent:      boolean;
    FTransparentColor: TColor;

    FMouseDown,
    FMouseInside:      boolean;
    FOnClick,
    FOnDblClick,
    FOnMouseEnter,
    FOnMouseExit:      TNotifyEvent;
    FOnMouseDown:      TMouseEvent;
    FOnMouseMove:      TMouseMoveEvent;
    FOnMouseUp:        TMouseEvent;

    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;

  protected
    procedure Paint; override;
    procedure Click; override;
    procedure DblClick; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;

    function  IsInsideButton(X,Y: Integer): boolean;

    procedure SetColor(newColor: TColor);
    procedure SetDown(newValue: boolean);
    procedure SetFlat(newValue: boolean);
    procedure SetFont(newFont: TFont);
    procedure SetGlyph(newGlyph: TBitmap);
    procedure SetLayout(newLayout: TButtonLayout);
    procedure SetMargin(newValue: integer);
    procedure SetNumGlyphs(newNumGlyphs: TNumGlyphs);
    procedure SetSpacing(newValue: integer);
    procedure SetTransparent(newValue: boolean);
    procedure SetTransparentColor(newColor: TColor);

    procedure PaintBorder;
    procedure PaintButton;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure CMTextChanged(var msg: TMessage);message CM_TEXTCHANGED;
    procedure CMDialogChar(var Message: TCMDialogChar);message CM_DIALOGCHAR;

  published
    {$IFDEF SR_Delphi5_Up}
    property Action;
    property Anchors;
    {$ENDIF}
    property Caption;
    property Color: TColor read FColor write SetColor;
    property Down: boolean read FDown write SetDown;
    property Enabled;
    property Flat: boolean read FFlat write SetFlat;
    property Font: TFont read FFont write SetFont;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property GroupIndex: integer read FGroupIndex write FGroupIndex;
    property Layout: TButtonLayout read FLayout write SetLayout;
    property Margin: integer read FMargin write SetMargin;
    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs default 0;
    property ParentFont;
    property ParentShowHint;
    {$IFDEF SR_Delphi3_Up}
    property PopupMenu;
    {$ENDIF}
    property ShowHint;
    property Spacing: integer read FSpacing write SetSpacing;
    property Transparent: boolean read FTransparent write SetTransparent;
    property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
    property Visible;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseExit: TNotifyEvent read FOnMouseExit  write FOnMouseExit;
  end;

procedure Register;

implementation

{$IFDEF SR_Delphi2_Up}
{$R *.D32}
uses rrColors;
{$ELSE}
{$R *.D16}
{$ENDIF}

const
  DefaultWidth  = 100;
  DefaultHeight = 50;
  FHLContrast   = 5;
  FShContrast   = 4;

function IsAccellerator(VK: Word; const Str: string): Boolean;
var
  P : Integer;
begin
  P := Pos('&', Str);
  Result := (P <> 0) and (P < Length(Str)) and
    (Upcase(Str[P + 1])=Upcase(Char(VK)));
end;

{$IFDEF SR_Delphi1}
function ChangeBrightness(Color:TColor;Percentage:longint):TColor;
var RGBColor       : longint;
    Red,Green,Blue : byte;
    NewR,NewG,NewB : longint;
    Overflow       : longint;
begin
  RGBColor:=ColorToRGB(Color);
  Overflow:=0;
  {Rot}
  Red:=GetRValue(RGBColor);
  NewR:=Red+(Percentage*Red div 100);
  if NewR>255 then begin
    Overflow:=NewR-255;
    NewG:=Overflow;
    NewB:=Overflow;
  end
  else begin
    NewG:=0;
    NewB:=0;
  end;
  {Grⁿn}
  Green:=GetGValue(RGBColor);
  NewG:=NewG+Green+(Percentage*Green div 100);
  if NewG>255 then begin
    Overflow:=NewG-255;
    NewR:=NewR+Overflow;
    NewB:=Overflow;
  end;
  {Blau}
  Blue:=GetBValue(RGBColor);
  NewB:=NewB+Blue+(Percentage*Blue div 100);
  if NewB>255 then begin
    Overflow:=NewB-255;
    if NewG<=255 then
      NewR:=NewR+Overflow;
  end;
  if NewR>255 then
    NewR:=255;
  if NewG>255 then
    NewG:=255;
  if NewB>255 then
    NewB:=255;
  if NewR<0 then
    NewR:=0;
  if NewG<0 then
    NewG:=0;
  if NewB<0 then
    NewB:=0;
  Result:=NewR+(NewG shl 8)+(NewB shl 16);
end;
{$ENDIF}

procedure AssignBevelColors(FaceColor:TColor;var HighlightColor,ShadowColor:TColor;HLContrast,ShContrast:integer);
begin
  {$IFDEF SR_Delphi1}
  HighlightColor:=ChangeBrightness(FaceColor,100 div 10*HLContrast);
  ShadowColor:=ChangeBrightness(FaceColor,-100 div 10*ShContrast);
  {$ELSE}
  Get3DColors(FaceColor,HighlightColor,ShadowColor,(10-HLContrast)/10,(10-ShContrast)/10);
  {$ENDIF}
end;


{ Komponente TOvalButton }
constructor TOvalButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  {Vorgabewerte setzen}
  FColor:=clBtnFace;
  AssignBevelColors(FColor,FColorHighlight,FColorShadow,FHLContrast,FShContrast);
  FDown:=false;
  FFlat:=false;
  FFont:=TFont.Create;
  FGlyph:=TBitmap.Create;
  FGroupIndex:=0;
  FNumGlyphs:=0;
  FSpacing :=4;
  FState:=1;
  FTransparent:=false;
  Height:=DefaultHeight;
  Width:=DefaultWidth;

  FMouseInside:=False;
  FMouseDown:=False;
end;

destructor  TOvalButton.Destroy;
begin
  FFont.Free;
  FGlyph.Free;
  inherited Destroy;
end;

procedure TOvalButton.SetColor(newColor: TColor);
begin
  if FColor<>newColor then begin
    FColor:=newColor;
    AssignBevelColors(FColor,FColorHighlight,FColorShadow,FHLContrast,FShContrast);
    Invalidate;
  end;
end;

procedure TOvalButton.SetDown(newValue: boolean);
begin
  if FDown<>newValue then begin
    FDown:=newValue;
    if FDown then
      FState:=-1
    else begin
      if FFlat then
        FState:=0
      else
        FState:=1;
    end;
    Invalidate;
  end;
end;

procedure TOvalButton.SetFlat(newValue: boolean);
begin
  if FFlat<>newValue then begin
    FFlat:=newValue;
    if FFlat then
      FState:=0
    else
      FState:=1;
    Invalidate;
  end;
end;

procedure TOvalButton.SetFont(newFont: TFont);
begin
  if FFont<>newFont then begin
    FFont.Assign(newFont);
    Invalidate;
  end;
end;

procedure TOvalButton.SetGlyph(newGlyph: TBitmap);
begin
  if(Assigned(FGlyph)) then begin
    FGlyph.Assign(newGlyph);
    FTransparentColor:=FGlyph.Canvas.Pixels[0,FGlyph.Height-1];

    if (csDesigning in ComponentState) then begin
      { Glyph 1: Normal, 2: Disabled, 3: Down;
        Mu▀ die Ausma▀e (Height * NumGlyphs) = Width  haben}
      if (newGlyph.width mod newGlyph.height=0) then
        FNumGlyphs:=newGlyph.width div newGlyph.height
      else
        FNumGlyphs:=1;
    end;

    Invalidate;
  end;
end;

procedure TOvalButton.SetLayout(newLayout: TButtonLayout);
begin
  if FLayout<>newLayout then begin
    FLayout:=newLayout;
    Invalidate;
  end;
end;

procedure TOvalButton.SetMargin(newValue: integer);
begin
  if FMargin<>newValue then begin
    FMargin:=newValue;
    Invalidate;
  end;
end;

procedure TOvalButton.SetNumGlyphs(newNumGlyphs: TNumGlyphs);
begin
  if FNumGlyphs<>newNumGlyphs then begin
    FNumGlyphs:=newNumGlyphs;
    Invalidate;
  end;
end;

procedure TOvalButton.SetSpacing(newValue: integer);
begin
  if FSpacing<>newValue then begin
    FSpacing:=newValue;
    Invalidate;
  end;
end;

procedure TOvalButton.SetTransparent(newValue: boolean);
begin
  if FTransparent<>newValue then begin
    FTransparent:=newValue;
    Invalidate;
  end;
end;

procedure TOvalButton.SetTransparentColor(newColor: TColor);
begin
  if FTransparentColor<>newColor then begin
    FTransparentColor:=newColor;
    Invalidate;
  end;
end;

function TOvalButton.IsInsideButton(X,Y: Integer):boolean;
var BtnEllipse : HRgn;
begin
  { Ist die Maus ⁿber der Button-Ellipse? }
  BtnEllipse:=CreateEllipticRgn(0,0,Width,Height);
  Result:=PtInRegion(BtnEllipse,X,Y);
  DeleteObject(BtnEllipse);
end;

procedure TOvalButton.Paint;
begin
  Canvas.Font.Assign(Font);
  with Canvas do begin
     if FTransparent then
       brush.Style:=bsClear
     else begin
       Brush.Style:=bsSolid;
       brush.color:=Color;
     end;
     if FFlat then
       pen.Style:=psClear
     else begin
       pen.Style:=psSolid;
       pen.color:=clBlack;
     end;
     { Button mit Farbe fⁿllen, schwarzen Rand zeichnen }
     Pen.Width:=1;
     Ellipse(0,0,width-1,height-1);
  end;

  { Den Rest zeichnen }
  PaintButton;
end;

procedure TOvalButton.PaintBorder;
begin
  with Canvas do begin
    pen.style:=psSolid;
    { linke obere Ecke zeichnen }
    if FState=-1 then  {down}
      pen.color:=FColorShadow;
    if FState=1 then  {up}
      pen.color:=FColorHighlight;
    if FState=0 then  {flat}
      pen.style:=psClear;
    Arc(1,1,width-2,height-2,width div 5 * 4,height div 5,width div 5,height div 5 * 4);
    { rechte untere Ecke zeichnen }
    if FState=-1 then  {down}
      pen.color:=FColorHighlight;
    if FState=1 then   {up}
      pen.color:=FColorShadow;
    Arc(1,1,width-2,height-2,width div 5,height div 5 * 4,width div 5 * 4,height div 5);
    pen.style:=psSolid;
  end;
end;

procedure TOvalButton.PaintButton;
var
  Dest,
  Source,
  TextR     : TRect;
  outWidth,
  outHeight,
  TextLeft,
  TextTop   : integer;
  outText   : array [0..79] of char;
begin
  { Glyph zeichnen ? }
  if Assigned(FGlyph) then begin
     with Source do begin
       { Source-Rechteck ermitteln }
       Left:=0;
       Right:=FGlyph.Width;
       Top:=0;
       Bottom:=FGlyph.Height;
       if FNumGlyphs>0 then
         Right:=Right div FNumGlyphs;
     end;
  end;

  PaintBorder;

  with Canvas do begin
    { Glyph anzeigen }
    outWidth:=0;
    outHeight:=0;
    if Assigned(FGlyph) and (FNumGlyphs>0) then begin
      if(Not Enabled and (FNumGlyphs>1)) then begin
        { disabled button }
        Source.Left:=FGlyph.width div FNumGlyphs;
        Source.Right:=Source.Left shl 1;
      end;
      { Gr÷▀e des Destination-Rechtecks }
      outWidth:=Source.Right-Source.Left;
      outHeight:=Source.Bottom-Source.Top;
      { Glyph-Position ermitteln }
      if (Caption='') or (FLayout=blGlyphTop) or (FLayout=blGlyphBottom) then begin
        Dest.Left:=((Width-outWidth) shr 1);
        Dest.Right:=((Width-outWidth) shr 1)+outWidth;
      end;
      if (Caption<>'') and (FLayout=blGlyphLeft) then begin
        Dest.Left:=((Width-(outWidth+FSpacing+TextWidth(Caption))) shr 1)-FMargin;
        Dest.Right:=Dest.Left+outWidth;
      end;
      if (Caption<>'') and (FLayout=blGlyphRight) then begin
        Dest.Left:=((Width+(outWidth+FSpacing+TextWidth(Caption))) shr 1)-outWidth+FMargin;
        Dest.Right:=Dest.Left+outWidth;
      end;
      if (Caption='') or (FLayout=blGlyphLeft) or (FLayout=blGlyphRight) then begin
        Dest.Top:=((Height-outHeight) shr 1);
        Dest.Bottom:=((Height-outHeight) shr 1)+outHeight;
      end;
      if (Caption<>'') and (FLayout=blGlyphTop) then begin
        Dest.Top:=((Height-(outHeight+FSpacing+TextHeight(Caption))) shr 1)-FMargin;
        Dest.Bottom:=Dest.Top+outHeight;
      end;
      if (Caption<>'') and (FLayout=blGlyphBottom) then begin
        Dest.Top:=((Height+(outHeight+FSpacing+TextHeight(Caption))) shr 1)-outHeight+FMargin;
        Dest.Bottom:=Dest.Top+outHeight;
      end;
      if FTransparent then
        Pen.Style:=psClear
      else begin
        Pen.Style:=psSolid;
        Pen.Color:=Color;
      end;
      if FState=-1 then begin {down}
        { Glyph um 1 Pixel nach rechts unten verschieben }
        Inc(Dest.Left);
        Inc(Dest.Right);
        Inc(Dest.Top);
        Inc(Dest.Bottom);
        { verbleibende Up-Reste l÷schen }
        MoveTo(Dest.Left-1,Dest.Bottom);
        LineTo(Dest.Left-1,Dest.Top-1);
        LineTo(Dest.Right,Dest.Top-1);
      end
      else begin
        { verbleibende Down-Reste l÷schen }
        MoveTo(Dest.Right,Dest.Top);
        LineTo(Dest.Right,Dest.Bottom);
        LineTo(Dest.Left,Dest.Bottom);
      end;
      Pen.Style := psSolid;
      if ((FState=-1) and (FNumGlyphs>2)) then begin
        { Glyph fⁿr gedrⁿckten Zustand bestimmen }
        Source.Left:=FGlyph.width div FNumGlyphs * 2;
        Source.Right:=FGlyph.width div FNumGlyphs * 3;
      end;
      if FTransparent then
        Brush.Style:=bsClear
      else begin
        Brush.Style:=bsSolid;
        Brush.Color:=Color;
      end;

      { Glyph zeichnen }
      BrushCopy(Dest, FGlyph, Source, FTransparentColor);
    end;

    { Caption zeichnen }
    if Caption<>'' then begin
      {Position ermitteln}
      TextLeft:=(width-TextWidth(Caption)) shr 1;
      if Assigned(FGlyph) and (FNumGlyphs>0) and (FLayout=blGlyphRight) then
        TextLeft:=Dest.Left-TextWidth(Caption)-FSpacing;
      if Assigned(FGlyph) and (FNumGlyphs>0) and (FLayout=blGlyphLeft) then
        TextLeft:=Dest.Left+outWidth+FSpacing;
      TextTop:=(height-TextHeight(Caption)) shr 1;
      if Assigned(FGlyph) and (FNumGlyphs>0) and (FLayout=blGlyphTop) then
        TextTop:=Dest.Top+outHeight+FSpacing;
      if Assigned(FGlyph) and (FNumGlyphs>0) and (FLayout=blGlyphBottom) then
        TextTop:=Dest.Top-TextHeight(Caption)-FSpacing;
      if FState=-1 then begin
        inc(TextTop);
        inc(TextLeft);
      end;
      {Text ausgeben}
      if FTransparent then
        Brush.Style:=bsClear
      else begin
        Brush.Style:=bsSolid;
        Brush.Color:=Color;
      end;
      if FState=-1 then
        { verbleibende Up-Reste l÷schen }
        FillRect(Rect(TextLeft,
                      TextTop,
                      TextLeft+TextWidth(Caption),
                      TextTop+TextHeight(Caption)))
      else
        { verbleibende Down-Reste l÷schen }
        FillRect(Rect(TextLeft+1,
                      TextTop+1,
                      TextLeft+1+TextWidth(Caption),
                      TextTop+1+TextHeight(Caption)));
      TextR:=Rect(TextLeft,
                  TextTop,
                  TextLeft+TextWidth(Caption),
                  TextTop+TextHeight(Caption));
      StrPCopy(outText,Caption);
      DrawText(Handle,
               outText,
               length(Caption),
               TextR,
               DT_SingleLine);
    end;
  end;
end;

procedure TOvalButton.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do begin
    if IsAccellerator(CharCode, Caption) then begin
      if Enabled then
        Click;
      Result:=1;
    end
    else
      inherited;
  end;
end;

procedure TOvalButton.Click;
begin
  if Enabled and FMouseInside then
    if Assigned(FOnClick) then
      FOnClick(Self);
end;

procedure TOvalButton.DblClick;
begin
  if Enabled and FMouseInside then
    if Assigned(FOnDblClick) then
      FOnDblClick(Self);
end;

procedure TOvalButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if (Enabled and IsInsideButton(X,Y)) then begin
    IsDown:=FDown;
    { Im gedrⁿckten Zustand neu zeichnen }
    FDown:=true;
    FState:=-1;
    if FTransparent then
      Invalidate
    else
      PaintButton;
    if Assigned(FOnMouseDown) then
      FOnMouseDown(Self, Button, Shift, X, Y);
  end;
  FMouseDown:= True;
end;

procedure TOvalButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if (Enabled and IsInsideButton(X,Y)) then begin
    { Im ungedrⁿckten Zustand neu zeichnen }
    if GroupIndex=0 then begin
      FDown:=false;
      FState:=1;
      if FTransparent then
        Invalidate
      else
        PaintButton;
    end
    else
      SetDown(not IsDown);
    { OnClick-Ereignis abfeuern }
    if Assigned(FOnMouseUp) then
      FOnMouseUp(Self, Button, Shift, X, Y);
  end;
  FMouseDown:= False;
end;

procedure TOvalButton.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if FMouseDown then begin
    if not IsInsideButton(X,Y) then begin
      { Button.Down aufheben, falls Maus Button verlΣsst }
      if (FState=-1) and (GroupIndex=0) and FMouseInside then begin
        FDown:=false;
        FState:=1;
        PaintBorder;
      end;
      FMouseInside:=false;
    end
    else begin
      { Button.Down setzen, falls Maus ⁿber Button }
      if (FState=1) and (GroupIndex=0) then begin
        FMouseInside:=true;
        FDown:=true;
        FState:=-1;
        PaintBorder;
      end;
    end;
  end
  else begin
    if FFlat and not FDown then begin
      if not IsInsideButton(X,Y) then begin
        { Button flach }
        if FMouseInside then begin
          FMouseInside:=false;
          FState:=0;
          Invalidate;
        end;
      end
      else begin
        { Button erhaben }
        FMouseInside:=true;
        FState:=1;
        PaintBorder;
      end;
    end
    else
      FMouseInside:=IsInsideButton(X,Y);
  end;
  if FMouseInside then
    if Assigned(FOnMouseMove) then
      FOnMouseMove(Self, Shift, X, Y);
end;

procedure TOvalButton.CMTextChanged(var msg: TMessage);
begin
  Invalidate;
end;

procedure TOvalButton.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  if assigned(FOnMouseEnter) then
    FOnMouseEnter(self);
end;

procedure TOvalButton.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if FMouseInside and Enabled then begin
    FMouseInside:=False;
    if FFlat and not FDown then begin
      FState:=0;
      Invalidate;
    end;
  end;
  if assigned(FOnMouseExit) then
    FOnMouseExit(Self);
end;

procedure Register;
begin
  RegisterComponents('Simon',[TOvalButton]);
end;

end.