БОЛЬШОЙ FAQ ПО DELPHI



Расширяем возможности кнопок в Delphi

Пример показывает, как сделать кнопку с тремя состояниями. В обычном состоянии она сливается с формой. При наведении на такую кнопку курсором мышки, она становится выпуклой. Ну и, соотвественно, при нажатии, кнопка становится вогнутой.

Пример тестировался под WinNT, SP5 и WIN95, SP1.

Также можно создать до 4-х изображений для индикации состояния кнопки

Вы так же можете присвоить кнопке текстовый заголовок. Можно расположить текст и изображение в любом месте кнопки. Для этого в пример добавлены четыре свойства:

TextTop и TextLeft
Для расположения текста заголовка на кнопке,
GlyphTop и GlyphLeft
Для расположения Glyph на кнопке.

Текст заголовка прорисовывается после изображения, потому что они используют одно пространство кнопки, и соответственно заголовок прорисуется поверх изображения. Бэкграунд текста сделан прозрачным. Соответственно мы увидим только текстовые символы поверх изображения.

Найденные баги

  1. Если двигать мышку очень быстро, то кнопка может не вернуться в исходное состояние
  2. Если кнопка находится в запрещённом состоянии, то при нажатии на неё, будет наблюдаться неприятное мерцание.

 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
     fGlyphTop,fGlyphLeft : Integer;
     // Верх и лево Glyph на изображении кнопки
     fTextTop,fTextLeft : Integer;
     // Верх и лево текста на изображении кнопки
     fNumGlyphs : Integer;
     // То же, что и в SpeedButton
     fCaption : string;
     // Текст на кнопке
     fFaceColor : TColor;
     // Цвет изображения (да-да, вы можете задавать цвет изображения кнопки
 
     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;
     // Таким способом компонент определяет - находится ли курсор мышки на нём или нет
     // Если курсор за пределами кнопки, то она всё равно продолжает принимать сообщения мышки.
     // Так же кнопка будет принимать сообщения, если на родительском окне нет фокуса.
 
   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 GlyphTop : Integer
     read fGlyphTop write fSetGlyphTop;
     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 TextTop : Integer
     read fTextTop write fSetTextTop;
 
     property Top;
     // 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.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);
   { Инициализируем переменные }
   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; // Освобождаем 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,fGlyphTop + 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,fGlyphTop,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,fGlyphTop,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 + fTextTop,fCaption)
     else
       Canvas.TextOut(fTextLeft,fTextTop,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.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Видеокурс ВЗЛОМ