Unit NewButton;

Interface

Uses

 Windows, Messages, SysUtils, Classes, Graphics, Controls,

 Forms, Dialogs;

Const

  fShift = 2; // Изменяем изображение и заголовок , когда кнопка нажата.

  fHiColor = $DDDDDD; // Цвет нажатой кнопки (светло серый)

  // Windows создаёт этот цвет путём смешивания пикселей clSilver и clWhite (50%).

  // такой цвет хорошо выделяет нажатую и отпущенную кнопки.

Type

 TNewButton = Class(TCustomControl)

 Private

  { Private declarations }

  fMouseOver,fMouseDown : Boolean;

  fEnabled : Boolean;

  // То же, что и всех компонент

  fGlyph : TPicture;

  // То же, что и в SpeedButton

  fGlyph,fGlyphLeft : Integer;

  // Верх и лево Glyph на изображении кнопки

  fText,fTextLeft : Integer;

  // Верх и лево текста на изображении кнопки

  fNumGlyphs : Integer;

  // То же, что и в SpeedButton

  fCaption : String;

  // Текст на кнопке

  fFaceColor : TColor;

  // Цвет изображения (да-да, вы можете задавать цвет изображения кнопки

  Procedure fLoadGlyph(G : TPicture);

  Procedure fSetGlyphLeft(I : Integer);

  Procedure fSetGlyph(I : Integer);

  Procedure fSetCaption(S : String);

  Procedure fSetText(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;

  // Таким способом компонент определяет - находится ли курсор мышки на нём или нет

  // Если курсор за пределами кнопки, то она всё равно продолжает принимать сообщения мышки.

  // Так же кнопка будет принимать сообщения, если на родительском окне нет фокуса.

 Public

  { Public declarations }

  Constructor Create(AOwner : TComponent); override;

  Destructor Destroy; override;

 Published

  { Published declarations }

  {----- Properties -----}

  Property Action;

  // Property AllowUp не поддерживается

  Property Anchors;

  Property BiDiMode;

  Property Caption : String

  read fCaption write fSetCaption;

  Property Constraints;

  Property Cursor;

  // Property Down не поддерживается

  Property Enabled : Boolean

  read fEnabled write fSetEnabled;

  // Property Flat не поддерживается

  Property FaceColor : TColor

  read fFaceColor write fSetFaceColor;

  Property Font;

  property Glyph : TPicture // Такой способ позволяет получить серую кнопку, которая сможет

  // находиться в трёх положениях.

  // После нажатия на кнопку, с помощью редактора картинок Delphi

  // можно будет создать картинки для всех положений кнопки..

  read fGlyph write fLoadGlyph;

  // Property GroupIndex не поддерживается

  Property GlyphLeft : Integer

  read fGlyphLeft write fSetGlyphLeft;

  Property Glyph : Integer

  read fGlyph write fSetGlyph;

  Property Height;

  Property Hint;

  // Property Layout не поддерживается

  Property Left;

  // Property Margin не поддерживается

  Property Name;

  Property NumGlyphs : Integer

  read fNumGlyphs write fSetNumGlyphs;

  Property ParentBiDiMode;

  Property ParentFont;

  Property ParentShowHint;

  // Property PopMenu не поддерживается

  Property ShowHint;

  // Property Spacing не поддерживается

  Property Tag;

  Property Textleft : Integer

  read fTextLeft write fSetTextLeft;

  Property Text : Integer

  read fText write fSetText;

  Property ;

  // Property Transparent не поддерживается

  Property Visible;

  Property Width;

  {--- События ---}

  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.fSetText(I : Integer);

Begin

If I >= 0 then

  If I <> fText then

  Begin

  fText := 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.fSetGlyph(I : Integer);

Begin

If I <> fGlyph then

  If I >= 0 then

  Begin

  fGlyph := 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);

{ Инициализируем переменные }

Height := 37;

Width := 37;

fMouseOver := False;

fGlyph := TPicture.Create;

fMouseDown := False;

fGlyphLeft := 2;

fGlyph := 2;

fTextLeft := 2;

fText := 2;

fFaceColor := clBtnFace;

fNumGlyphs := 1;

fEnabled := True;

End;

{--------------------------------------------------------------------}

Destructor TNewButton.Destroy;

Begin

If Assigned(fGlyph) then

  fGlyph.Free; // Освобождаем 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)); // получаем caption

If Buffer <> '' then

  fCaption := Buffer;

If fEnabled = False then

  fMouseDown := False; // если недоступна, значит и не нажата

If fMouseDown then

  Begin

  fBtnColor := fHiColor; // Цвет нажатой кнопки

  fColor1 := clWhite; // Правая и нижняя окантовка кнопки, когда на неё нажали мышкой.

  fColor2 := clBlack; // Верхняя и левая окантовка кнопки, когда на неё нажали мышкой.

  End

else

  Begin

  fBtnColor := fFaceColor; // fFaceColor мы сами определяем

  fColor2 := clWhite; // Цвет левого и верхнего края кнопки, когда на неё находится курсор мышки

  fColor1 := clGray; // Цвет правого и нижнего края кнопки, когда на неё находится курсор мышки

  End;

// Рисуем лицо кнопки :)

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 загружен?

  Begin

  If fEnabled then  // Кнопка разрешена?

  Begin

  If fMouseDown then // Мышка нажата?

  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 < 3) and (fNumGlyphs > 1)then

  TempGlyph.Bitmap.Canvas.CopyRect(DestRect,

  fGlyph.Bitmap.Canvas,Rect(X0,0,X1,Y0));

  If (fNumGlyphs = 1) then

  TempGlyph.Assign(fGlyph);

  // Извините, лучшего способа не придумал...

  // Glyph.Bitmap.Прозрачность цвета не работает, если Вы выберете в качестве

  // прозрачного цвета 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;

  //Рисуем саму кнопку

  Canvas.Draw(fGlyphLeft + 2,fGlyph + 2,TempGlyph.Graphic);

  End

  else

  Begin

  If fMouseOver then

  Begin

  // Курсор на кнопке, но не нажат, показываем Glyph 1 на морде кнопки

  // (если существует)

  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

  // Курсор за пределами кнопки, показываем Glyph 2 на морде кнопки (если есть)

  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;

  // Извиняюсь, лучшего способа не нашёл...

  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;

  //Рисуем bitmap на морде кнопки

  Canvas.Draw(fGlyphLeft,fGlyph,TempGlyph.Graphic);

  End;

  End

  else

  Begin

  // Кнопка не доступна (disabled), показываем Glyph 4 на морде кнопки (если существует)

  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);

  // Извините, лучшего способа не нашлось...

  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;

  //Рисуем изображение кнопки

  Canvas.Draw(fGlyphLeft,fGlyph,TempGlyph.Graphic);

  End;

  End;

// Рисуем 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 + fText,fCaption)

  else

  Canvas.TextOut(fTextLeft,fText,fCaption);

  End;

TempGlyph.Free; // Освобождаем временный glyph

End;

{--------------------------------------------------------------------}

// Нажата клавиша мышки на кнопке ?

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; // не перерисовываем кнопку без необходимости.

  End;

Inherited MouseDown(Button,Shift,X,Y);;

End;

{--------------------------------------------------------------------}

// Отпущена клавиша мышки на кнопке ?

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; // не перерисовываем кнопку без необходимости.

  End;

Inherited MouseUp(Button,Shift,X,Y);

End;

{--------------------------------------------------------------------}

// Эта процедура перехватывает события мышки, если она даже за пределами кнопки

// Перехватываем оконные сообщения

Procedure TNewButton.WndProc(var Message : TMessage);

Var

  P1,P2 : TPoint;

  Bo : Boolean;

Begin

If Parent <> nil then

  Begin

  GetCursorPos(P1); // Получаем координаты курсона на экране

  P2 := Self.ScreenToClient(P1); // Преобразуем их в координаты относительно кнопки

  If (P2.X > 0) and (P2.X < Width) and

  (P2.Y > 0) and (P2.Y < Height) then

  Bo := True // Курсор мышки в области кнопки

  else

  Bo := False; // Курсор мышки за пределами кнопки

  If Bo <> fMouseOver then // не перерисовываем кнопку без необходимости.

  Begin

  fMouseOver := Bo;

  Invalidate;

  End;

  End;

inherited WndProc(Message); // отправляем сообщение остальным получателям

End;

{--------------------------------------------------------------------}

End.

{====================================================================}