Knapeffekt - onMouseOut

Ved at bruge en normal SpeedButton istedet for en alm. knap kan du løse problemet da en speedbutton automatisk gør op igen når man flytter musen væk fra den (Det gjorde den ihvertfald i mit Delphi 5 jeg må indrømme at jeg ikke kan huske om den også virker sådan i delphi 3, men det er da et forsøg værd).

Hvis det er så kan jeg også godt lave noget kode til dig der kan gøre det ved at udregne musens position i forhold til den knap, men så skal jeg lige se koden under din Mouseover event først.

- Der tages forbehold for stavefejl, jeg er IKKE vågen endnu :p

Ellers kan du jo bare implemtere en ny knap : her er koden til en der gør præcis som du beskriver det :

unit ExpBtn;

{  Internet Explorer style 'Active Button' written by Jens Borrisholt, February 1999.
  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 WMRButtonDown (var Message: TWMRButtonDown); message wm_RButtonDown;
    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
    x, y: Integer;
    Glyph: TBitmap;
    txtRect, bitRect, glyphRect: TRect;

    procedure DrawMenuGlyph (x, y: Integer; Color: TColor; Style: TBrushStyle);
    begin
        with Canvas do
        begin
            Pen.Color := Color;
            Brush.Color := clBlack;
            Brush.Style := Style;
            Canvas.Polygon([Point (x, y), Point (x + 8, y), Point (x + 4, y + 4)]);
        end;
    end;

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;

        { Draw the drop-down menu 'glyph' }
        if PopupMenu <> Nil then
        begin
            x := Width - 14; y := 4;
            if Enabled then
            begin
                if fState = bsDown then begin Inc (x); Inc (y); end;
                DrawMenuGlyph (x, y, clBlack, bsSolid);
            end
            else
            begin
                DrawMenuGlyph (x, y, clBtnShadow, bsClear);
                DrawMenuGlyph (x + 1, y + 1, clBtnHighlight, bsClear);
            end;
        end;

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

procedure TExplorerButton.WMRButtonDown (var Message: TWMRButtonDown);
begin
    { Disable AutoPopup before calling Inherited }
    if PopupMenu <> Nil then PopupMenu.AutoPopup := False;
    Inherited;
end;

procedure TExplorerButton.WMLButtonDown (var Message: TWMLButtonDown);
var
    pt: TPoint;
    InControl: Boolean;
begin
    Inherited;
    InControl := PtInRect (GetClientRect, Point (Message.XPos, Message.YPos));

    if InControl then
    begin
        MouseCapture := True;
        fState := bsDown;
        Invalidate;

        if PopupMenu <> Nil then
        begin
            pt := Parent.ClientToScreen (Point (Left - 1, Top + Height));
            PopupMenu.Alignment := paLeft;
            PopupMenu.PopupComponent := Self;
            PopupMenu.Popup (pt.x, pt.y);
            fState := bsInactive;
            MouseCapture := False;
            Invalidate;
        end;
    end;
end;

procedure TExplorerButton.WMMouseMove (var Message: TWMMouseMove);
var
    InControl: Boolean;
begin
    Inherited;
    InControl := PtInRect (GetClientRect, Point (Message.XPos, Message.YPos));

    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, Point (Message.XPos, Message.YPos));

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

    Invalidate;
end;

procedure Register;
begin
    RegisterComponents('Samples', [TExplorerButton]);
end;

end.


Jens B

dj>>
SpeedButton klarer opgaven med glamour - no problems

borrisholt>>
... derfor anvender jeg ovennævnte, da din metode kræver noget mere. Jeg har ikke checket men formoder, du har ret

din ExpBtn er genial... smukt med baggrundsfarve og billede...

hvordan kan man få den til at starte med at se ud som "rigtige" knapper uden at man først skal køre musen hen over knappen?

:greenland:

selvfølgelig,, man sætter bare fState := bsactive; :-)

Long time no see:-)

Nu fandt jeg lige din geniale knap i et af mine test projekter.

Jeg savner dog en enkelt genial ting, og det er muligheden for at kunne flytte og resize knappen.

Jeg kan se at den mangler egenskaberne:
DragCursor
DragKind
DragMode

Hvordan kan man tilføje dette til ExpBtn?

mvh
greenland