Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

Курс видеоуроков программирования и крэкерства 5.0
(актуальность: январь 2017)
Свежие инструменты, новые видеоуроки!

  • 300+ видеоуроков
  • 800 инструментов
  • 80 свежих книг и статей

УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Четвёртая кнопка на заголовочной полосе окна



 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   ComCtrls, ExtCtrls, StdCtrls;
 
 const
   wm_BtnClk = wm_User + 111;{Определяем своё сообщение}
 
 type
   TForm1 = class(TForm)
     procedure FormDestroy(Sender: TObject);
   private
     { Private declarations }
     R: TRect;{Переменная для обозначения прямоугольной области кнопки}
     Press: Boolean;
     procedure WmNcPaint(var Msg: TWmNcPaint); message wm_NcPaint;
     procedure WMNcActivate(var msg: TwmncActivate); message wm_NcActivate;
     procedure WmNcLButtonDown( var Msg: TWMNCLBUTTONDOWN); message Wm_NCLbuttonDown;
     procedure wmnchittest(var Msg: TWMncHITTEST); message wm_NcHittest;
     procedure wmSize(var Msg: TMessage); message wm_Size;
     procedure wmncLButtonUp(var msg: TWMncLBUTTONUP); message wm_NclButtonUp;
     procedure wmLbuttonUp(var Msg: TMessage); message wm_LbuttonUp;
     procedure wmBtnClk(var msg: TMessage); message wm_BtnClk;
   public
     { Public declarations }
     procedure DrawBtn;
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 { TForm1 }
 
 procedure TForm1.WmNcPaint(var Msg: TWmNcPaint);
 begin
   inherited;
   Drawbtn;{При перерисовке окна прорисовываем кнопку}
 end;
 
 procedure TForm1.DrawBtn;{Код прорисовки кнопки}
 var
   WDc: HDc;
   Cx, Cy: Integer;
   XFrame, Yframe: Integer;
 begin
   {Получаем контекст нашего окна, снимаем мерки с оконных размеров,
   вычисляем положение нашей кнопки и прорисовываем её в зависимости
   от того нажата ли кнопка мыши над ней}
   WDc := GetWindowDc(Handle);
   Cx := GetSystemMetrics(SM_CXSize);
   Cy := GetSystemMetrics(SM_CYSize);
   xFrame := GetSystemMetrics(SM_CXFrame);
   yFrame := GetSystemMetrics(SM_CYFrame);
   R := Bounds(Width - xFrame - 4*Cx + 2, yFrame + 2, Cx - 2, Cy - 4);
   if Press then
     DrawFrameControl(WDc,R,DFC_BUTTON,DFCS_ButtonPUSH or DFCS_PUSHED)
   else
     DrawFrameControl(WDc,R,DFC_BUTTON,DFCS_ButtonPUSH);
   ReleaseDc(Handle,WDC);
 end;
 
 procedure TForm1.WMNcActivate(var msg: TwmncActivate);
 begin
   inherited;
   DrawBtn;
 end;
 
 procedure TForm1.WmNcLButtonDown(var Msg: TWMNCLBUTTONDOWN);
 var
   pt: TPoint;
 begin
   inherited;
   drawbtn;
   pt := Point(msg.XCursor - Left,msg.YCursor - top);
   if PtInRect(R,pt) then
   begin
     Press := True;
     drawbtn;
   end;
 end;
 
 
 procedure TForm1.wmnchittest(var Msg: TWMncHITTEST);
 var
   pt: tpoint;
 begin
   inherited;
   pt :=Point(msg.XPos - Left, msg.YPos - Top);
   if PtinRect(r,pt) then
     msg.Result := htBorder;
 end;
 
 procedure TForm1.wmSize(var Msg: TMessage);
 begin
   inherited;
   RedrawWindow(Handle, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT
     or RDW_INVALIDATE);
 end;
 
 procedure TForm1.wmncLButtonUp(var msg: TWMncLBUTTONUP);
 var
   pt: TPoint;
 begin
   inherited;
   pt := Point(msg.XCursor - Left,msg.YCursor - top);
   if PtInRect(R,pt) then
   begin
     Press := False;
     drawbtn;
     PostMessage(Handle,wm_btnClk,0,0);
   end;
 end;
 
 procedure TForm1.wmLbuttonUp(var Msg: TMessage);
 begin
   inherited;
   if Press then
   begin
     Press := False;
     DrawBtn;
   end;
 end;
 
 procedure TForm1.wmBtnClk(var msg: TMessage);
 begin
   {Объявили константу своего сообщения,
   посылаем его своему окну при отпускании кнопки мыши над новой кнопкой,
   а здесь обрабатываем своё сообщение}
   ShowMessage('О, круто, наша кнопка нажимается! Спасибо проекту Delphi World!');
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   RedrawWindow(Handle, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT
     or RDW_INVALIDATE);
 end;
 
 end.
 




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



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



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS