Mega Code Archive
The buttons of Delphis palette bar simulated
<![CDATA[
Title: The buttons of Delphi's palette bar simulated
Question: How to write a button which elevates when the mouse is/goes over it, and which is flat when the mouse is not over it?
Answer:
Unit NewButton;
Interface
(*
=====================================================================
Delphi Component
---------------------------------------------------------------------
Written in Delphi 5 professional, tested under WinNT, SP5 and WIN95,
SP1.
Explanation
-----------
This is a button which works just like the buttons of Delphi's
palette. When the mouse is/goes over the button, it elevates and when
the mouse is leaves the button, it becomes flat again. The button also
reacts if the window, where the button is on, is out of focus.
You can supply up to four bitmaps in a row to indicate the button
status.
+-----+-----+-----+-----+ ^
|mouse|mouse|clic-|dis- | |
|over | not | ked |abled| Height
| | over| | | |
+-----+-----+-----+-----+ v
Picture
You can design this bitmap in the Delphi tool: "Image Edit".
The component will automatically adjust the property: NumGlyphs after
loading the Icon / Bitmap for the button face. Supplying a Picture or
Bitmap / Icon is optional. If you don't want this automatically
calculated value of NumGlyphs, you can alter it AFTER loading the
Icon / Bitmap / Picture.
You can also give the button a caption text. You can position the
caption text and the bitmap anywhere on the button face. I've added
four properties to do that:
TextTop and TextLeft, to position the Caption text on the button face,
and:
GlyphTop and GlyphLeft, to position the Glyph on the button face.
Also in this case, the origin (0,0) is positioned on the left-top of
the caption, of the picture and of the button.
The caption text is drawn after the bitmap, so when they take
(partially) the same space on the button face, the caption text will
be written OVER the bitmap. The background of the text is made
transparent. So you'll only see the characters if you draw the text
over the bitmap.
You can use and alter this component freely.
For remarks, suggestions, improvements, enhancements, please send me
an email at: M.deHaan@inn.nl
Known bugs
----------
1) If you move the mouse very, very quickly over the button, it
sometimes happens that the button doesn't become flat again after
leaving the button. Do you have any suggestions to solve this minor
problem?
2) The button face flickers when the button is disabled and you click
on it with the mouse.
=====================================================================
*)
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs;
Const
fShift = 2; // Shift of the bitmap and/or caption when the button
// is pressed.
fHiColor = $DDDDDD; // Button pressed face color (super light gray)
// Windows simulates this color by mixing pixels of
// clSilver and clWhite (50%).
// Just take a good look at the scrollbar, between the
// up and down buttons and the slider.
Type
TNewButton = Class(TCustomControl)
Private
{ Private declarations }
fMouseOver,fMouseDown : Boolean;
fEnabled : Boolean;
// The same as all components
fGlyph : TPicture;
// The same as in SpeedButton
fGlyphTop,fGlyphLeft : Integer;
// Upper left of Glyph on the
// face of the button
fTextTop,fTextLeft : Integer;
// Upper left of the text on
// the face of the button
fNumGlyphs : Integer;
// The same as in SpeedButton
fCaption : String;
// Text on the face of the
// button
fFaceColor : TColor;
// Face color
// Yes you can give the face a
// color.
Procedure fLoadGlyph(G : TPicture);
Procedure fSetGlyphLeft(I : Integer);
Procedure fSetGlyphTop(I : Integer);
Procedure fSetCaption(S : String);
Procedure fSetTextTop(I : Integer);
Procedure fSetTextLeft(I : Integer);
Procedure fSetFaceColor(C : TColor);
Procedure fSetNumGlyphs(I : Integer);
Procedure fSetEnabled(B : Boolean);
Protected
{ Protected declarations }
Procedure Paint; override;
Procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
Procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
Procedure WndProc(var Message : TMessage); override;
// This is how the component finds out if mouse is over or not!
// If the mouse is NOT over the component, it will still
// receive mouse messages. Also, if the parent window is NOT
// in focus, the component will still receive mouse messages.
Public
{ Public declarations }
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
Published
{ Published declarations }
{----- Properties -----}
Property Action;
// Property AllowUp is not implemented
Property Anchors;
Property BiDiMode;
Property Caption : String
read fCaption write fSetCaption;
Property Constraints;
Property Cursor;
// Property Down is not implemented
Property Enabled : Boolean
read fEnabled write fSetEnabled;
// Property Flat is not implemented
Property FaceColor : TColor
read fFaceColor write fSetFaceColor;
Property Font;
property Glyph : TPicture // This is the way to get Delphi's
// Gray button with three points on it.
// After pressing this button, Delphi's
// "Picture Editor" is launched in order
// to load the bitmap.
read fGlyph write fLoadGlyph;
// Property GroupIndex is not implemented
Property GlyphLeft : Integer
read fGlyphLeft write fSetGlyphLeft;
Property GlyphTop : Integer
read fGlyphTop write fSetGlyphTop;
Property Height;
Property Hint;
// Property Layout is not implemented
Property Left;
// Property Margin is not implemented
Property Name;
Property NumGlyphs : Integer
read fNumGlyphs write fSetNumGlyphs;
Property ParentBiDiMode;
Property ParentFont;
Property ParentShowHint;
// Property PopMenu is not implemented
Property ShowHint;
// Property Spacing is not implemented
Property Tag;
Property Textleft : Integer
read fTextLeft write fSetTextLeft;
Property TextTop : Integer
read fTextTop write fSetTextTop;
Property Top;
// Property Transparent is not implemented
Property Visible;
Property Width;
{--- Events ---}
Property OnClick;
Property OnDblClick;
Property OnMouseDown;
Property OnMouseMove;
Property OnMouseUp;
end;
Procedure Register; // Hello
Implementation
{--------------------------------------------------------------------}
Procedure TNewButton.fSetEnabled(B : Boolean);
Begin
If B fEnabled then
Begin
fEnabled := B;
Invalidate;
End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetNumGlyphs(I : Integer);
Begin
If I 0 then
If I fNumGlyphs then
Begin
fNumGlyphs := I;
Invalidate;
End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetFaceColor(C : TColor);
Begin
If C fFaceColor then
Begin
fFaceColor := C;
Invalidate;
End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetTextTop(I : Integer);
Begin
If I = 0 then
If I fTextTop then
Begin
fTextTop := I;
Invalidate;
End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetTextLeft(I : Integer);
Begin
If I = 0 then
If I fTextLeft then
Begin
fTextLeft := I;
Invalidate;
End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetCaption(S : String);
Begin
If (fCaption S) then
Begin
fCaption := S;
SetTextBuf(PChar(S));
Invalidate;
End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetGlyphLeft(I : Integer);
Begin
If I fGlyphLeft then
If I = 0 then
Begin
fGlyphLeft := I;
Invalidate;
End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetGlyphTop(I : Integer);
Begin
If I fGlyphTop then
If I = 0 then
Begin
fGlyphTop := I;
Invalidate;
End;
End;
{--------------------------------------------------------------------}
procedure tNewButton.fLoadGlyph(G : TPicture);
Var
I : Integer;
Begin
fGlyph.Assign(G);
If fGlyph.Height 0 then
Begin
I := fGlyph.Width div fGlyph.Height;
If I fNumGlyphs then
fNumGlyphs := I;
End;
Invalidate;
End;
{--------------------------------------------------------------------}
Procedure Register; // Hello
Begin
RegisterComponents('Samples', [TNewButton]);
End;
{--------------------------------------------------------------------}
Constructor TNewButton.Create(AOwner : TComponent);
Begin
Inherited Create(AOwner);
{ Initialise variables }
Height := 37;
Width := 37;
fMouseOver := False;
fGlyph := TPicture.Create;
fMouseDown := False;
fGlyphLeft := 2;
fGlyphTop := 2;
fTextLeft := 2;
fTextTop := 2;
fFaceColor := clBtnFace;
fNumGlyphs := 1;
fEnabled := True;
End;
{--------------------------------------------------------------------}
Destructor TNewButton.Destroy;
Begin
If Assigned(fGlyph) then
fGlyph.Free; // Free the glyph
inherited Destroy;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.Paint;
Var
fBtnColor,fColor1,fColor2,
fTransParentColor : TColor;
Buffer : Array[0..127] of Char;
I,J : Integer;
X0,X1,X2,X3,X4,Y0 : Integer;
DestRect : TRect;
TempGlyph : TPicture;
Begin
X0 := 0;
X1 := fGlyph.Width div fNumGlyphs;
X2 := X1 + X1;
X3 := X2 + X1;
X4 := X3 + X1;
Y0 := fGlyph.Height;
TempGlyph := TPicture.Create;
TempGlyph.Bitmap.Width := X1;
TempGlyph.Bitmap.Height := Y0;
DestRect := Rect(0,0,X1,Y0);
GetTextBuf(Buffer,SizeOf(Buffer)); // Get the caption
If Buffer '' then
fCaption := Buffer;
If fEnabled = False then
fMouseDown := False; // correct for disabled
If fMouseDown then
Begin
fBtnColor := fHiColor; // Button down color
fColor1 := clWhite; // Right and bottom border color of button
// when mouse is down
fColor2 := clBlack; // Left and top border color when mouse is
// down
End
else
Begin
fBtnColor := fFaceColor; // fFaceColor is user defined
fColor2 := clWhite; // Left and top color when mouse is over
fColor1 := clGray; // Right and bottom border color when
// mouse is over
End;
// Paint the button face
Canvas.Brush.Color := fBtnColor;
Canvas.FillRect(Rect(1,1,Width - 2,Height - 2));
If fMouseOver then
Begin
Canvas.MoveTo(Width,0);
Canvas.Pen.Color := fColor2;
Canvas.LineTo(0,0);
Canvas.LineTo(0,Height - 1);
Canvas.Pen.Color := fColor1;
Canvas.LineTo(Width - 1,Height - 1);
Canvas.LineTo(Width - 1, - 1);
End;
If Assigned(fGlyph) then // Bitmap loaded?
Begin
If fEnabled then // Button enabled?
Begin
If fMouseDown then // Mouse down?
Begin
// Mouse down on the button so show Glyph 3 on the face
If (fNumGlyphs = 3) then
TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
fGlyph.Bitmap.Canvas,Rect(X2,0,X3,Y0));
If (fNumGlyphs 1)then
TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
fGlyph.Bitmap.Canvas,Rect(X0,0,X1,Y0));
If (fNumGlyphs = 1) then
TempGlyph.Assign(fGlyph);
// Sorry, I couldn't find a better way...
// Glyph.Bitmap.Transparentcolor doesn't work when the
// color that you want to be transparent is clWhite...
fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
For I := 0 to X1 - 1 do
For J := 0 to Y0 - 1 do
If TempGlyph.Bitmap.Canvas.Pixels[I,J] =
fTransParentColor then
TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
//Draw the bitmap on the button face
Canvas.Draw(fGlyphLeft + 2,fGlyphTop + 2,TempGlyph.Graphic);
End
else
Begin
If fMouseOver then
Begin
// Mouse over, but not down, so show Glyph 1 on the face
// (if exists)
If (fNumGlyphs 1) then
TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
fGlyph.Bitmap.Canvas,Rect(0,0,X1,Y0));
If (fNumGlyphs = 1) then
TempGlyph.Assign(fGlyph);
End
else
Begin
// Mouse not over, so show Glyph 2 on the face (if exists)
If (fNumGlyphs 1) then
TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
fGlyph.Bitmap.Canvas,Rect(X1,0,X2,Y0));
If (fNumGlyphs = 1) then
TempGlyph.Assign(fGlyph);
End;
// Sorry, I couldn't find a better way...
fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
For I := 0 to X1 - 1 do
For J := 0 to Y0 - 1 do
If TempGlyph.Bitmap.Canvas.Pixels[I,J] =
fTransParentColor then
TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
//Draw the bitmap on the button face
Canvas.Draw(fGlyphLeft,fGlyphTop,TempGlyph.Graphic);
End;
End
else
Begin
// The button is disabled, so show Glyph 4 on the face (if
// exists)
If (fNumGlyphs = 4) then
TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
fGlyph.Bitmap.Canvas,Rect(X3,0,X4,Y0))
else
TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
fGlyph.Bitmap.Canvas,Rect(0,0,X1,Y0));
If (fNumGlyphs = 1) then
TempGlyph.Assign(fGlyph.Graphic);
// Sorry, I couldn't find a better way...
fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
For I := 0 to X1 - 1 do
For J := 0 to Y0 - 1 do
If TempGlyph.Bitmap.Canvas.Pixels[I,J] =
fTransParentColor then
TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
//Draw the buttonface
Canvas.Draw(fGlyphLeft,fGlyphTop,TempGlyph.Graphic);
End;
End;
// Draw the caption
If fCaption '' then
Begin
Canvas.Pen.Color := Font.Color;
Canvas.Font.Name := Font.Name;
Canvas.Brush.Style := bsClear;
//Canvas.Brush.Color := fBtnColor;
Canvas.Font.Color := Font.Color;
Canvas.Font.Size := Font.Size;
Canvas.Font.Style := Font.Style;
If fMouseDown then
Canvas.TextOut(fShift + fTextLeft,fShift + fTextTop,fCaption)
else
Canvas.TextOut(fTextLeft,fTextTop,fCaption);
End;
TempGlyph.Free; // Free the temp glyph
End;
{--------------------------------------------------------------------}
// Is the mouse up or down within the control?
Procedure TNewButton.MouseDown(Button: TMouseButton;
Shift: TShiftState;X, Y: Integer);
Var
ffMouseDown,ffMouseOver : Boolean;
Begin
ffMouseDown := True;
ffMouseOver := True;
If (ffMouseDown fMouseDown) or (ffMouseOver fMouseOver) then
Begin
fMouseDown := ffMouseDown;
fMouseOver := ffMouseOver;
Invalidate; // Don't redraw the button if it is not necessary
End;
Inherited MouseDown(Button,Shift,X,Y);;
End;
{--------------------------------------------------------------------}
// Is the mouse up or down within the control?
Procedure TNewButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
Var
ffMouseDown,ffMouseOver : Boolean;
Begin
ffMouseDown := False;
ffMouseOver := True;
If (ffMouseDown fMouseDown) or (ffMouseOver fMouseOver) then
Begin
fMouseDown := ffMouseDown;
fMouseOver := ffMouseOver;
Invalidate; // Don't redraw the button if it is not necessary
End;
Inherited MouseUp(Button,Shift,X,Y);
End;
{--------------------------------------------------------------------}
// This procedure catches the mouse even if it is not over the
// control
// Interception of window messages
Procedure TNewButton.WndProc(var Message : TMessage);
Var
P1,P2 : TPoint;
Bo : Boolean;
Begin
If Parent nil then
Begin
GetCursorPos(P1); // Get mouse position on screen
P2 := Self.ScreenToClient(P1); // Convert it to coordinates
// relative to the origin of
// the control
If (P2.X 0) and (P2.X (P2.Y 0) and (P2.Y Bo := True // Mouse is within the control
else
Bo := False; // Mouse is outside the control
If Bo fMouseOver then // Don't redraw the button if it is not
// necessary.
Begin
fMouseOver := Bo;
Invalidate;
End;
End;
inherited WndProc(Message); // Send the windows messages to the other
// clients
End;
{--------------------------------------------------------------------}
End.
{====================================================================}
]]>