PC Pro 1997 May/pcpro0597.iso/code/visuprog/ExpBtn.pas

Pascal/Delphi Source File | 1997-02-04 | 9.8 KB | 351 lines

unit ExpBtn;

{  Internet Explorer style 'Active Button' written by Dave Jewell, February 1997.

   Todo: popup menu }

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Menus;

type
  TExpBtnState = (bsInactive, bsActive, bsDown, bsDownAndOut);
  TGlyphPosition = (bsTop, bsBottom, bsLeft, bsRight);

  TExplorerButton = class(TCustomControl)
  private
    { Private declarations }
    fCaption: String;
    fInactive: TBitmap;
    fActive: TBitmap;
    fDisabled: TBitmap;
    fState: TExpBtnState;
    fMouseExit: TNotifyEvent;
    fMouseEnter: TNotifyEvent;
    fTransparentColor: TColor;
    fGlyphPosition: TGlyphPosition;
    procedure DrawFrame;
    procedure SetCaption (const Val: String);
    procedure SetInactiveGlyph (Val: TBitmap);
    procedure SetActiveGlyph (Val: TBitmap);
    procedure SetDisabledGlyph (Val: TBitmap);
    function CurrentGlyph: TBitmap;
    procedure SetTransparentColor (Val: TColor);
    procedure SetGlyphPosition (Val: TGlyphPosition);
    procedure Layout (var txtRect, bitRect: TRect);
  protected
    { Protected declarations }
    procedure Paint; override;
    procedure WMLButtonDown (var Message: TWMLButtonDown); message wm_LButtonDown;
    procedure WMMouseMove (var Message: TWMMouseMove); message wm_MouseMove;
    procedure WMLButtonUp (var Message: TWMLButtonUp); message wm_LButtonUp;
    procedure CMEnabledChanged (var Message: TMessage); message cm_EnabledChanged;
  public
    { Public declarations }
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Color;
    property Font;
    property Enabled;
    property ParentFont;
    property PopupMenu;
    property ShowHint;
    property ParentShowHint;
    property Visible;
    property OnClick;
    property Align;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property Caption: String read fCaption write SetCaption;
    property GlyphInactive: TBitmap read fInactive write SetInactiveGlyph;
    property GlyphActive: TBitmap read fActive write SetActiveGlyph;
    property GlyphDisabled: TBitmap read fDisabled write SetDisabledGlyph;
    property Position: TGlyphPosition read fGlyphPosition write SetGlyphPosition default bsTop;
    property TransparentColor: TColor read fTransparentColor write SetTransparentColor default clOlive;
    property OnMouseExit: TNotifyEvent read fMouseExit write fMouseExit;
    property OnMouseEnter: TNotifyEvent read fMouseEnter write fMouseEnter;
  end;

procedure Register;

implementation

{ TExplorerButton }

constructor TExplorerButton.Create (AOwner: TComponent);
begin
    Inherited Create (AOwner);
    fInactive := TBitmap.Create;
    fActive := TBitmap.Create;
    fDisabled := TBitmap.Create;
    fState := bsInactive;
    fGlyphPosition := bsTop;
    fTransparentColor := clOlive;
    Width := 50; Height := 40;
end;

destructor TExplorerButton.Destroy;
begin
    fInactive.Free;
    fActive.Free;
    fDisabled.Free;
    Inherited Destroy;
end;

procedure TExplorerButton.CMEnabledChanged (var Message: TMessage);
begin
    Inherited;
    Invalidate;
end;

procedure TExplorerButton.SetInactiveGlyph (Val: TBitmap);
begin
    fInactive.Assign (Val);
    Invalidate;
end;

procedure TExplorerButton.SetActiveGlyph (Val: TBitmap);
begin
    fActive.Assign (Val);
    Invalidate;
end;

procedure TExplorerButton.SetDisabledGlyph (Val: TBitmap);
begin
    fDisabled.Assign (Val);
    Invalidate;
end;

procedure TExplorerButton.SetCaption (const Val: String);
begin
    if fCaption <> Val then
    begin
        fCaption := Val;
        Invalidate;
    end;
end;

procedure TExplorerButton.SetTransparentColor (Val: TColor);
begin
    if fTransparentColor <> Val then
    begin
        fTransparentColor := Val;
        Invalidate;
    end;
end;

procedure TExplorerButton.SetGlyphPosition (Val: TGlyphPosition);
begin
    if fGlyphPosition <> Val then
    begin
        fGlyphPosition := Val;
        Invalidate;
    end;
end;

function TExplorerButton.CurrentGlyph: TBitmap;
begin
    { Default to inactive glyph - use others if present }
    Result := fInactive;
    if (fState in [bsActive, bsDown]) and (not fActive.Empty) then Result := fActive;
    if (not Enabled) and (not fDisabled.Empty) then Result := fDisabled;
end;

procedure TExplorerButton.DrawFrame;
var
    rClient: TRect;
    State: TExpBtnState;
    LT, BR: TColor;
begin
    State := fState;
    rClient := ClientRect;
    { If we're designing, draw component in 'Active' state }
    if csDesigning in ComponentState then State := bsActive;
    { Only Active and Down states have a border }
    if State in [bsDown, bsActive] then with Canvas do
    begin
        if State = bsActive then
        begin
            LT := clBtnHighlight; BR := clBtnShadow;
        end
        else
        begin
            LT := clBtnShadow; BR := clBtnHighlight;
        end;

        with rClient do
        begin
            Pen.Color := LT;
            MoveTo (Right - 1, 0); LineTo (0, 0);
            LineTo (0, Bottom - 1);
            Pen.Color := BR;
            MoveTo (1, Bottom - 1);
            LineTo (Right - 1, Bottom - 1);
            MoveTo (Right - 1, 1);
            LineTo (Right - 1, Bottom);
        end;
    end;
end;

procedure TExplorerButton.Layout (var txtRect, bitRect: TRect);
var
    hBit, vBit, hTxt, vTxt: Integer;
begin
    hBit := bitRect.Right - bitRect.Left;
    vBit := bitRect.Bottom - bitRect.Top;
    hTxt := txtRect.Right - txtRect.Left;
    vTxt := txtRect.Bottom - txtRect.Top;

    case fGlyphPosition of
        bsTop, bsBottom:
        begin
            bitRect.Left := (Width - hBit) div 2;
            txtRect.Left := (Width - hTxt) div 2;
            bitRect.Top := (Height - (vBit + vTxt)) div 2;
            txtRect.Top := bitRect.Top + vBit;
        end;

        bsLeft, bsRight:
        begin
            bitRect.Top := (Height - vBit) div 2;
            txtRect.Top := (Height - vTxt) div 2;
            bitRect.Left := (Width - (hBit + hTxt)) div 2;
            txtRect.Left := bitRect.Left + hBit;
        end;
    end;

    bitRect.Right := bitRect.Left + hBit;
    bitRect.Bottom := bitRect.Top + vBit;
    txtRect.Right := txtRect.Left + hTxt;
    txtRect.Bottom := txtRect.Top + vTxt;

    { If button down, draw text and glyph down and to the right }
    if fState = bsDown then
    begin
        OffsetRect (bitRect, 1, 1);
        OffsetRect (txtRect, 1, 1);
    end;
end;

procedure TExplorerButton.Paint;
var
    Glyph: TBitmap;
    txtRect, bitRect, glyphRect: TRect;
begin
    with Canvas do
    begin
        { Fill control background }
        Brush.Color := Color;
        Brush.Style := bsSolid;
        FillRect (ClientRect);
        { Draw control frame - if applicable }
        DrawFrame;
        { Figure out size of text and display bitmaps }
        Font := Self.Font;
        Glyph := CurrentGlyph;
        txtRect := Rect (0, 0, TextWidth (Caption), TextHeight (Caption));
        bitRect := Rect (0, 0, Glyph.Width, Glyph.Height);
        glyphRect := bitRect;
        { Now calculate position of text and bitmap }
        if fGlyphPosition in [bsTop, bsLeft] then Layout (txtRect, bitRect)
        else Layout (bitRect, txtRect);

        { First, draw the caption }
        Brush.Style := bsClear;
        if Enabled then TextRect (txtRect, txtRect.left, txtRect.top, fCaption) else
        begin
            Font.Color := clBtnShadow;
            TextRect (txtRect, txtRect.left, txtRect.top, fCaption);
            OffsetRect (txtRect, 1, 1);
            Font.Color := clBtnHighlight;
            TextRect (txtRect, txtRect.left, txtRect.top, fCaption);
        end;

        { Finally, draw the glyph }
        Brush.Color := Color;
        BrushCopy (bitRect, Glyph, glyphRect, fTransparentColor);
    end;
end;

procedure TExplorerButton.WMLButtonDown (var Message: TWMLButtonDown);
var
    InControl: Boolean;
begin
    Inherited;
    InControl := PtInRect (GetClientRect, Message.Pos);
    if InControl then
    begin
        MouseCapture := True;
        fState := bsDown;
        Invalidate;
    end;
end;

procedure TExplorerButton.WMMouseMove (var Message: TWMMouseMove);
var
    InControl: Boolean;
begin
    Inherited;
    InControl := PtInRect (GetClientRect, Message.Pos);
    if (fState = bsDown) and (not InControl) then
    begin
        fState := bsDownAndOut; Invalidate;
    end;

    if (fState = bsDownAndOut) and InControl then
    begin
        fState := bsDown; Invalidate;
    end;

    case fState of
        bsInActive:  if InControl then
                     begin
                         fState := bsActive;
                         if Assigned (fMouseEnter) then fMouseEnter (Self);
                         MouseCapture := True;
                         Invalidate;
                     end;
        bsActive:    if not InControl then
                     begin
                         fState := bsInActive;
                         if Assigned (fMouseExit) then fMouseExit (Self);
                         MouseCapture := False;
                         Invalidate;
                     end;
    end;
end;

procedure TExplorerButton.WMLButtonUp (var Message: TWMLButtonUp);
var
    InControl: Boolean;
begin
    Inherited;
    InControl := PtInRect (GetClientRect, Message.Pos);

    if InControl then
    begin
        fState := bsActive;
        MouseCapture := True;
    end
    else
    begin
        fState := bsInactive;
        MouseCapture := False;
    end;

    Invalidate;
end;

procedure Register;
begin
    RegisterComponents('Pilgrim''s Progress', [TExplorerButton]);
end;

end.