VPF::Рисуем Button - Форум программистов

ivan219

Дата 6.2.2007, 00:37 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1121
Регистрация: 19.11.2005
Где: Планета земля

Репутация: 2
Всего: 12

Romikgy, распиши эти сообщения smile

Код


     procedure WMPaint(var Message: TWMPaint); message WM_PAINT; //Начало рисования
     procedure mmoud(var Message: TWMPaint); message WM_LBUTTONDOWN; //Нажать левую кнопку мыши
     procedure mmouu(var Message: TWMPaint); message WM_LBUTTONUP; //Отпустить левую кнопку мыши
     procedure dclk(var Message: TWMPaint); message WM_LBUTTONDBLCLK; //????????

--------------------

Мой первый сайт и моя первая программа!!!!!

Romikgy

Дата 6.2.2007, 00:42 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 26
Всего: 146

имхо все есть в мсдн

Цитата(ivan219 @ 5.2.2007, 23:37

)

message WM_LBUTTONDBLCLK; //????????

двойной клик на кнопке
, почему обрабатываю все эти команды, потому как кнопка это отдельное окно, имеет свою очередь сообщений, можно ее всю перехватить, но мне лень было ,
и я показал , как можно отрисовать перехватив только изменения картинки,
ибо

Цитата(ivan219 @ 5.2.2007, 23:37

)

WM_PAINT

вызывается когда кнопка отрисовывается изначально или после свертывания,
а при нажатии срабатывает другое сообщение, при отпускании третье, и рисование происходит по разным путям, хотя внизу вызывается одна и таже ф_ция, лень искать было ...

--------------------

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

ivan219

Дата 6.2.2007, 09:51 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1121
Регистрация: 19.11.2005
Где: Планета земля

Репутация: 2
Всего: 12

MCDN там всё по английски а есть с русским переводом smile

--------------------

Мой первый сайт и моя первая программа!!!!!

ivan219

Дата 6.2.2007, 17:16 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1121
Регистрация: 19.11.2005
Где: Планета земля

Репутация: 2
Всего: 12

Вот что вышло:

Код


Unit Mb;
interface

uses
  Windows,SysUtils, Classes, Controls, StdCtrls, Messages, Graphics,Forms;

Type
 Tmb=class ( TButton )
   private
     hd: HDC;
     FCanvas: TCanvas;
     R: TRect;
   public
     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
     procedure mmoud(var Message: TWMPaint); message WM_LBUTTONDOWN;
     procedure mmouu(var Message: TWMPaint); message WM_LBUTTONUP;
     procedure dclk(var Message: TWMPaint); message WM_LBUTTONDBLCLK;
  end;
{ Tmb }
Type
    AArray=Array[0..2,0..20] of TColor;
const
    Col: AArray=((15591399,15722985,15854571,15986157,16117743,
                  16117743,16117743,16117743,15920364,15722985,
                  15525606,15328227,15130848,14933469,14736090,
                  14538711,14341332,14143953,13946574,13749195,
                  13551816),
                 (14736090,15065055,15394020,15657192,15920364,
                  16117743,16315122,16512501,16644087,16709880,
                  16775673,16709880,16644087,16512501,16315122,
                  16117743,15920364,15657192,15394020,15065055,
                  14736090),
                 (8946306,9143685,9341064,9538443,9735822,
                  9933201,10130580,10327959,10525338,10722717,
                  10920096,11117475,11314854,11512233,11512233,
                  11512233,11512233,11380647,11249061,11117475,
                  10985889));

implementation

uses Unit1;

procedure Tmb.dclk(var Message: TWMPaint);
var
   Y,C: Integer;
begin
 inherited;
 C:=0;
 for Y:=R.Top+1 to R.Bottom-2 do
  begin
   FCanvas := TCanvas.Create;
   FCanvas.Lock;
   FCanvas.Handle:=hd;
   FCanvas.Pen.Color:=Col[0,C];
   FCanvas.MoveTo(R.Left+1,Y);
   FCanvas.LineTo(R.Right-1,Y);
   Inc(C);
  end;
 FCanvas.Pen.Color:=$00CFCFCF;
 FCanvas.Brush.Style:=bsClear;
 FCanvas.RoundRect(R.Left,R.Top,R.Right,R.Bottom,5,5);
 FCanvas.TextOut(R.Left+18,R.Top+5,'Button1');
end;

procedure Tmb.mmoud(var Message: TWMPaint);
var
   Y,C: Integer;
begin
 inherited;
 C:=0;
 for Y:=R.Top+1 to R.Bottom-2 do
  begin
   FCanvas := TCanvas.Create;
   FCanvas.Lock;
   FCanvas.Handle:=hd;
   FCanvas.Pen.Color:=Col[2,C];
   FCanvas.MoveTo(R.Left+1,Y);
   FCanvas.LineTo(R.Right-1,Y);
   Inc(C);
  end;
 FCanvas.Pen.Color:=$00CFCFCF;
 FCanvas.Brush.Style:=bsClear;
 FCanvas.RoundRect(R.Left,R.Top,R.Right,R.Bottom,5,5);
 FCanvas.TextOut(R.Left+18,R.Top+5,'Button1');

end;

procedure Tmb.mmouu(var Message: TWMPaint);
var
   Y,C: Integer;
begin
 inherited;
 C:=0;
 for Y:=R.Top+1 to R.Bottom-2 do
  begin
   FCanvas := TCanvas.Create;
   FCanvas.Lock;
   FCanvas.Handle:=hd;
   FCanvas.Pen.Color:=Col[0,C];
   FCanvas.MoveTo(R.Left+1,Y);
   FCanvas.LineTo(R.Right-1,Y);
   Inc(C);
  end;
 FCanvas.Pen.Color:=$00CFCFCF;
 FCanvas.Brush.Style:=bsClear;
 FCanvas.RoundRect(R.Left,R.Top,R.Right,R.Bottom,5,5);
 FCanvas.TextOut(R.Left+18,R.Top+5,'Button1');
end;

procedure Tmb.WMPaint(var Message: TWMPaint);
var
  h: HWND;
  Y,C: Integer;

begin
 inherited;
 C:=0;
 R.Top:=0;
 R.Bottom:=23;
 R.Left:=0;
 R.Right:=73;
 hd:=GetDeviceContext(h);
 for Y:=R.Top+1 to R.Bottom-2 do
  begin
   FCanvas := TCanvas.Create;
   FCanvas.Lock;
   FCanvas.Handle:=hd;
   FCanvas.Pen.Color:=Col[0,C];
   FCanvas.MoveTo(R.Left+1,Y);
   FCanvas.LineTo(R.Right-1,Y);
   Inc(C);
  end;
 FCanvas.Pen.Color:=$00CFCFCF;
 FCanvas.Brush.Style:=bsClear;
 FCanvas.RoundRect(R.Left,R.Top,R.Right,R.Bottom,5,5);
 FCanvas.TextOut(R.Left+18,R.Top+5,'Button1');
end;
end.

Только есть некоторые минусы.
При наведении мышкой на кнопку рисунок исчезает наверное надо обрабатывать ещё одно сообщение, также видны уголки прямоугольно кнопки может можно её вообще стереть smile

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

Romikgy

Дата 6.2.2007, 18:23 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 26
Всего: 146

Цитата(ivan219 @ 6.2.2007, 16:16

)

При наведении мышкой на кнопку рисунок исчезает наверное надо обрабатывать ещё одно сообщение,

WM_MOUSEMOVE

Цитата(ivan219 @ 6.2.2007, 16:16

)

также видны уголки прямоугольно кнопки может можно её вообще стереть

Цитата(ivan219 @ 6.2.2007, 16:16

)

for Y:=R.Top+1 to R.Bottom-2 do

зачем тогда эти плюсы и минусы?

--------------------

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

ivan219

Дата 6.2.2007, 18:38 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1121
Регистрация: 19.11.2005
Где: Планета земля

Репутация: 2
Всего: 12

А у меня там две рисовалки первая рисует прямоугольник по строчно от R.Top+1 до R.Bottom-2

Код


for Y:=R.Top+1 to R.Bottom-2 do

А вторая обводку вокруг него R.Left,R.Top,R.Right,R.Bottom получается красивая кнопка.

Код


 Canvas.Pen.Color:=$00CFCFCF;
 Canvas.Brush.Style:=bsClear;
 Canvas.RoundRect(R.Left,R.Top,R.Right,R.Bottom,5,5);

Углы выходят за пределы моей кнопки так как уменя там ничего не рисуется вот и остаётся старая кнопка.

Добавлено @ 18:47
По 3 пикселя на каждом углу попробую их зарисовать но может есть другая возможность.

Добавлено @ 18:51
Но попрежнему после первого ножатия на кнопку она не периресовывается только после второго это происходит.

--------------------

Мой первый сайт и моя первая программа!!!!!

ivan219

Дата 6.2.2007, 19:11 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1121
Регистрация: 19.11.2005
Где: Планета земля

Репутация: 2
Всего: 12

Работает

Код


Unit Mb;
interface

uses
  Windows,SysUtils, Classes, Controls, StdCtrls, Messages, Graphics,Forms;

Type
 Tmb=class ( TButton )
   private
     H: HWND;
     HD: HDC;
     FCanvas: TCanvas;
     R: TRect;
   public
     procedure PAINT(var Message: TWMPaint); message WM_PAINT;
     procedure MOVE(var Message: TWMPaint); message WM_MOUSEMOVE;
     procedure DOWN(var Message: TWMPaint); message WM_LBUTTONDOWN;
     procedure DBLCLK(var Message: TWMPaint); message WM_LBUTTONDBLCLK;
     procedure UP(var Message: TWMPaint); message WM_LBUTTONUP;
     procedure DrawButton(A: Byte);
  end;

Type
    AArray=Array[0..2,0..20] of TColor;
const
    Col: AArray=((15591399,15722985,15854571,15986157,16117743,
                  16117743,16117743,16117743,15920364,15722985,
                  15525606,15328227,15130848,14933469,14736090,
                  14538711,14341332,14143953,13946574,13749195,
                  13551816),
                 (14736090,15065055,15394020,15657192,15920364,
                  16117743,16315122,16512501,16644087,16709880,
                  16775673,16709880,16644087,16512501,16315122,
                  16117743,15920364,15657192,15394020,15065055,
                  14736090),
                 (8946306,9143685,9341064,9538443,9735822,
                  9933201,10130580,10327959,10525338,10722717,
                  10920096,11117475,11314854,11512233,11512233,
                  11512233,11512233,11380647,11249061,11117475,
                  10985889));

implementation

procedure Tmb.PAINT(var Message: TWMPaint);
begin
 if HD=0 then  DrawButton(0);
end;

procedure Tmb.MOVE(var Message: TWMPaint);
begin
 DrawButton(1);
end;

procedure Tmb.DOWN(var Message: TWMPaint);
begin
 DrawButton(2);
end;

procedure Tmb.DBLCLK(var Message: TWMPaint);
begin
 DrawButton(2);
end;

procedure Tmb.UP(var Message: TWMPaint);
begin
 DrawButton(1);
end;

procedure Tmb.DrawButton(A: Byte);
var
  Y,C: Integer;
begin
 C:=0;
 R.Top:=0;
 R.Bottom:=25;
 R.Left:=0;
 R.Right:=75;
 HD:=GetDeviceContext(H);
 for Y:=R.Top+1 to R.Bottom-2 do
  begin
   FCanvas:=TCanvas.Create;
   FCanvas.Lock;
   FCanvas.Handle:=HD;
   case A of
        0: FCanvas.Pen.Color:=Col[0,C];
        1: FCanvas.Pen.Color:=Col[1,C];
        2: FCanvas.Pen.Color:=Col[2,C];
   end;
   FCanvas.MoveTo(R.Left+1,Y);
   FCanvas.LineTo(R.Right-1,Y);
   if C<20 then Inc(C);
  end;
 FCanvas.Pen.Color:=$00CFCFCF;
 FCanvas.Brush.Style:=bsClear;
 FCanvas.RoundRect(R.Left,R.Top,R.Right,R.Bottom,5,5);
 FCanvas.TextOut(R.Left+18,R.Top+5,'Button1');
end;
end.

Правда есть ещё один минус когда мышка на кнопке происходит

Код


procedure MOVE(var Message: TWMPaint); message WM_MOUSEMOVE;

А что делать если мыши нет на кнопке smile

--------------------

Мой первый сайт и моя первая программа!!!!!

Romikgy

Дата 6.2.2007, 20:01 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 26
Всего: 146

Цитата(ivan219 @ 6.2.2007, 18:11

)

А что делать если мыши нет на кнопке

а если над компонентом ничего не происходит так он имхо и не перерисовывается,
или перефразируй вопрос?

--------------------

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

ivan219

Дата 6.2.2007, 20:12 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1121
Регистрация: 19.11.2005
Где: Планета земля

Репутация: 2
Всего: 12

Ну если сночало мышка была на кнопке WM_MOUSEMOVE; потом убрал с кнопки что произойдёт smile

Да и ещё пару багов нашол:
1: Когда форму скрываеш то кнопка исчезает виновата вот этот код

Код


procedure TMyButton.PAINT(var Message: TWMPaint);
begin
 //if HD=0 then
   DrawButton(0);
end;

но если делать просто

Код


procedure TMyButton.PAINT(var Message: TWMPaint);
begin
   DrawButton(0);
end;

то кнопка мирцает что посоветуете smile

2: Если на форме XPmanyfest то другие кнопки обычные TButton если их нажать остаются в токомже положении что делать smile

Добавлено @ 20:17
Если вот так то всё работает но видны уголки прямоугольной кнопки.

Код


procedure TMyButton.PAINT(var Message: TWMPaint);
begin
 //if HD=0 then
 inherited;
  DrawButton(0);
end;

--------------------

Мой первый сайт и моя первая программа!!!!!

Romikgy

Дата 6.2.2007, 21:23 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 26
Всего: 146

выложи проект я его посмотрю

--------------------

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

ivan219

Дата 6.2.2007, 22:00 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1121
Регистрация: 19.11.2005
Где: Планета земля

Репутация: 2
Всего: 12

Код


Unit MyButton;
interface

uses
  Windows,SysUtils, Classes, Controls, StdCtrls, Messages, Graphics, Forms, Dialogs;

Type
 TMyButton=class (TButton)
   private
     H: HWND;
     HD: HDC;
     FCanvas: TCanvas;
   protected
   
   public
     procedure PAINT(var Message: TWMPaint); message WM_PAINT;
     procedure MOVE(var Message: TWMPaint); message WM_MOUSEMOVE;
     procedure DOWN(var Message: TWMPaint); message WM_LBUTTONDOWN;
     procedure DBLCLK(var Message: TWMPaint); message WM_LBUTTONDBLCLK;
     procedure UP(var Message: TWMPaint); message WM_LBUTTONUP;
     procedure DrawButton(A: Byte);
   published
  end;

Type
    AArray=Array[0..2,0..20] of TColor;
const
    Col: AArray=((15591399,15722985,15854571,15986157,16117743,
                  16117743,16117743,16117743,15920364,15722985,
                  15525606,15328227,15130848,14933469,14736090,
                  14538711,14341332,14143953,13946574,13749195,
                  13551816),
                 (14736090,15065055,15394020,15657192,15920364,
                  16117743,16315122,16512501,16644087,16709880,
                  16775673,16709880,16644087,16512501,16315122,
                  16117743,15920364,15657192,15394020,15065055,
                  14736090),
                 (8946306,9143685,9341064,9538443,9735822,
                  9933201,10130580,10327959,10525338,10722717,
                  10920096,11117475,11314854,11512233,11512233,
                  11512233,11512233,11380647,11249061,11117475,
                  10985889));

procedure Register;

implementation

uses Unit1;

procedure Register;
begin
  RegisterComponents('Standard', [TMyButton]);
end;

procedure TMyButton.PAINT(var Message: TWMPaint);
begin
 inherited;
 DrawButton(0);
end;

procedure TMyButton.MOVE(var Message: TWMPaint);
begin
 DrawButton(1);
end;

procedure TMyButton.DOWN(var Message: TWMPaint);
begin
 DrawButton(2);
end;

procedure TMyButton.DBLCLK(var Message: TWMPaint);
begin
 DrawButton(2);
end;

procedure TMyButton.UP(var Message: TWMPaint);
begin
 DrawButton(1);
end;

procedure TMyButton.DrawButton(A: Byte);
var
  Y,C: Integer;
begin
 C:=0;
 HD:=GetDeviceContext(H);
 FCanvas:=TCanvas.Create;
 FCanvas.Handle:=HD;
 for Y:=1 to ClientHeight-2 do
  begin
   case A of
        0: FCanvas.Pen.Color:=Col[0,C];
        1: FCanvas.Pen.Color:=Col[1,C];
        2: FCanvas.Pen.Color:=Col[2,C];
   end;
   FCanvas.MoveTo(1,Y);
   FCanvas.LineTo(ClientWidth-1,Y);
   if C<20 then Inc(C);
  end;
 FCanvas.Pen.Color:=$00CFCFCF;
 FCanvas.Brush.Style:=bsClear;
 FCanvas.RoundRect(0,0,ClientWidth,ClientHeight,5,5);
 FCanvas.TextOut((ClientWidth-FCanvas.TextWidth(Text)) div 2,
                 (ClientHeight-FCanvas.TextHeight(Text)) div 2,Text);
 FCanvas.Free;
end;
end.

Вызов.

Код


procedure TForm1.Button1Click(Sender: TObject);
begin
 with TMyButton.Create(Self) do
  begin
   Top:=10;
   Left:=10;
   Caption:='Button';
   Parent:=Self;
  end;
end;

Но всё равно при первом ножатии кнопка перерисовывается нетак как надо.

Это сообщение отредактировал(а) ivan219 - 6.2.2007, 22:39

--------------------

Мой первый сайт и моя первая программа!!!!!

Romikgy

Дата 6.2.2007, 22:57 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 26
Всего: 146

немного поправил

Код


Unit MyButton;
interface
uses
  Windows,SysUtils, Classes, Controls, StdCtrls, Messages, Graphics, Forms, Dialogs;
Type
 TMyButton=class (TButton)
   private
     H: HWND;
     HD: HDC;
     FCanvas: TCanvas;
     R: TRect;
   protected
   
   public
     procedure PAINT(var Message: TWMPaint); message WM_PAINT;
     procedure MOVE(var Message: TMessage); message CM_MOUSEENTER;
     procedure MOVEl(var Message: TMessage); message CM_MOUSELEAVE;
     procedure DOWN(var Message: TMessage); message WM_LBUTTONDOWN;
     procedure DBLCLK(var Message: TMessage); message WM_LBUTTONDBLCLK;
     procedure UP(var Message: TMessage); message WM_LBUTTONUP;
     procedure DrawButton(A: Byte);
   published
  end;
Type
    AArray=Array[0..2,0..20] of TColor;
const
    Col: AArray=((15591399,15722985,15854571,15986157,16117743,
                  16117743,16117743,16117743,15920364,15722985,
                  15525606,15328227,15130848,14933469,14736090,
                  14538711,14341332,14143953,13946574,13749195,
                  13551816),
                 (14736090,15065055,15394020,15657192,15920364,
                  16117743,16315122,16512501,16644087,16709880,
                  16775673,16709880,16644087,16512501,16315122,
                  16117743,15920364,15657192,15394020,15065055,
                  14736090),
                 (8946306,9143685,9341064,9538443,9735822,
                  9933201,10130580,10327959,10525338,10722717,
                  10920096,11117475,11314854,11512233,11512233,
                  11512233,11512233,11380647,11249061,11117475,
                  10985889));
procedure Register;
implementation
uses Variants;
procedure Register;
begin
  RegisterComponents('Standard', [TMyButton]);
end;
procedure TMyButton.PAINT(var Message: TWMPaint);
begin
 inherited;

  DrawButton(0);
end;
procedure TMyButton.MOVE(var Message: TMessage);
begin

 DrawButton(1);
end;
procedure TMyButton.DOWN(var Message: TMessage);
begin
 DrawButton(2);
end;
procedure TMyButton.DBLCLK(var Message: TMessage);
begin
 DrawButton(2);
end;
procedure TMyButton.UP(var Message: TMessage);
begin
 DrawButton(1);
end;
procedure TMyButton.DrawButton(A: Byte);
var
  Y,C: Integer;
  CenterText: TRect;
begin
 C:=0;
 R.Top:=0;
 R.Bottom:=25;
 R.Left:=0;
 R.Right:=75;
 HD:=GetDeviceContext(H);
 for Y:=R.Top+1 to R.Bottom-2 do
  begin
   FCanvas:=TCanvas.Create;
 //  FCanvas.Lock;
   FCanvas.Handle:=HD;
   case A of
        0: FCanvas.Pen.Color:=Col[0,C];
        1: FCanvas.Pen.Color:=Col[1,C];
        2: FCanvas.Pen.Color:=Col[2,C];
   end;
   FCanvas.MoveTo(R.Left+1,Y);
   FCanvas.LineTo(R.Right-1,Y);
   if C<20 then Inc(C);
  end;
 FCanvas.Pen.Color:=$00CFCFCF;
 FCanvas.Brush.Style:=bsClear;
 FCanvas.RoundRect(R.Left,R.Top,R.Right,R.Bottom,5,5);
 CenterText.Left:=(R.Right-FCanvas.TextWidth(Text)) div 2;
 CenterText.Top:=(R.Bottom-FCanvas.TextHeight(Text)) div 2;
 FCanvas.TextOut(CenterText.Left,CenterText.Top,Text);
end;
procedure TMyButton.MOVEl(var Message: TMessage);
begin
  DrawButton(0);
end;

end.

Цитата(ivan219 @ 6.2.2007, 21:00

)

Но всё равно при первом ножатии кнопка перерисовывается нетак как надо.

на это смотрю,
там происходит вызоввм_паинта и он рисует первую картику smile

--------------------

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

Romikgy

Дата 6.2.2007, 23:12 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 26
Всего: 146

окончательный вариант

Код


Unit MyButton;
interface
uses
  Windows,SysUtils, Classes, Controls, StdCtrls, Messages, Graphics, Forms, Dialogs;
Type
 TMyButton=class (TButton)
   private
     H: HWND;
     HD: HDC;
     FCanvas: TCanvas;
     R: TRect;
     lbd, under: Boolean;
   protected
   
   public
     procedure PAINT(var Message: TWMPaint); message WM_PAINT;
     procedure MOVE(var Message: TMessage); message CM_MOUSEENTER;
     procedure MOVEl(var Message: TMessage); message CM_MOUSELEAVE;
     procedure DOWN(var Message: TMessage); message WM_LBUTTONDOWN;
     procedure DBLCLK(var Message: TMessage); message WM_LBUTTONDBLCLK;
     procedure UP(var Message: TMessage); message WM_LBUTTONUP;
     procedure DrawButton(A: Byte);
     constructor Create(AOwner: TComponent); override;
   published
  end;
Type
    AArray=Array[0..2,0..20] of TColor;
const
    Col: AArray=((15591399,15722985,15854571,15986157,16117743,
                  16117743,16117743,16117743,15920364,15722985,
                  15525606,15328227,15130848,14933469,14736090,
                  14538711,14341332,14143953,13946574,13749195,
                  13551816),
                 (14736090,15065055,15394020,15657192,15920364,
                  16117743,16315122,16512501,16644087,16709880,
                  16775673,16709880,16644087,16512501,16315122,
                  16117743,15920364,15657192,15394020,15065055,
                  14736090),
                 (8946306,9143685,9341064,9538443,9735822,
                  9933201,10130580,10327959,10525338,10722717,
                  10920096,11117475,11314854,11512233,11512233,
                  11512233,11512233,11380647,11249061,11117475,
                  10985889));
procedure Register;
implementation
uses Variants;
procedure Register;
begin
  RegisterComponents('Standard', [TMyButton]);
end;
procedure TMyButton.PAINT(var Message: TWMPaint);
begin
 inherited;
  if under then
  begin
   if lbd then
    DrawButton(2)
   else
   DrawButton(1);
  end
  else
  DrawButton(0);
end;
procedure TMyButton.MOVE(var Message: TMessage);
begin
 under:=True;
 DrawButton(1);
end;
procedure TMyButton.DOWN(var Message: TMessage);
begin
  lbd:=True;
 DrawButton(2);
end;
procedure TMyButton.DBLCLK(var Message: TMessage);
begin
 DrawButton(2);
end;
procedure TMyButton.UP(var Message: TMessage);
begin
  lbd:=False;
 DrawButton(1);
end;
procedure TMyButton.DrawButton(A: Byte);
var
  Y,C: Integer;
  CenterText: TRect;
begin
 C:=0;
 R.Top:=0;
 R.Bottom:=25;
 R.Left:=0;
 R.Right:=75;
 HD:=GetDeviceContext(H);
 for Y:=R.Top+1 to R.Bottom-2 do
  begin
   FCanvas:=TCanvas.Create;
 //  FCanvas.Lock;
   FCanvas.Handle:=HD;
   case A of
        0: FCanvas.Pen.Color:=Col[0,C];
        1: FCanvas.Pen.Color:=Col[1,C];
        2: FCanvas.Pen.Color:=Col[2,C];
   end;
   FCanvas.MoveTo(R.Left+1,Y);
   FCanvas.LineTo(R.Right-1,Y);
   if C<20 then Inc(C);
  end;
 FCanvas.Pen.Color:=$00CFCFCF;
 FCanvas.Brush.Style:=bsClear;
 FCanvas.RoundRect(R.Left,R.Top,R.Right,R.Bottom,5,5);
 CenterText.Left:=(R.Right-FCanvas.TextWidth(Text)) div 2;
 CenterText.Top:=(R.Bottom-FCanvas.TextHeight(Text)) div 2;
 FCanvas.TextOut(CenterText.Left,CenterText.Top,Text);
end;
procedure TMyButton.MOVEl(var Message: TMessage);
begin
  under:=False;
  DrawButton(0);
end;

constructor TMyButton.Create(AOwner: TComponent);
begin
  inherited;
  lbd:=False;
  under:=False;

end;

end.

--------------------

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

ivan219

Дата 6.2.2007, 23:49 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1121
Регистрация: 19.11.2005
Где: Планета земля

Репутация: 2
Всего: 12

Romikgy, Спасибо smile

всё работает smile

Возник один вопрос от куда в переменной H взялось значение что потом я из него Hendl вытянул smile

Код


Type
 TMyButton=class(TButton)
   private
     H: HWND;
     HD: HDC;
.
.
HD:=GetDeviceContext(H);

--------------------

Мой первый сайт и моя первая программа!!!!!

Romikgy

Дата 6.2.2007, 23:54 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 26
Всего: 146

Цитата(ivan219 @ 6.2.2007, 22:49

)

Возник один вопрос от куда в переменной H взялось значение что потом я из него Hendl вытянул

этого я сам не знаю smile

но так насколько помнится было в хелпе дельфей, я в этом коде ничего не менял smile

--------------------

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »