Forms

← →
_vitek_ (2003-01-11 23:01) [0]

Подскажите пожалуйста, как создать программно доп. кнопку к стандартным [_][#][X] , если это возможно ?

← →
TTCustomDelphiMaster (2003-01-11 23:36) [1]

Есть готовые компоненты. Или рисуй руками.

← →
Song (2003-01-12 10:34) [2]

DrawFrameControl()

← →
John (2003-01-12 11:24) [3]

Если передвигать по экрану форму, то кнопка исчезает. Все дабоает на D7
....
const
wm_BtnClk = wm_User + 111;
type
...FormDestroy
private
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
procedure DrawBtn;
...
rocedure 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
close;end;
...FormDestroy:
begin
RedrawWindow(Handle, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT or RDW_INVALIDATE); end; end.

← →
cdadmitriy (2003-01-12 11:51) [4]

Отличное решение ....

http://www.maxcomponents.net/

← →
Юрий Зотов (2003-01-12 12:34) [5]

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

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Edit1: TEdit;
private
function DrawButton(State: Cardinal): boolean;
procedure WMNCLButtonDown(var Message: TWMNCLButtonDown ); message WM_NCLBUTTONDOWN;
procedure WMLButtonUp(var Message: TWMLButtonUp ); message WM_LBUTTONUP;
protected
procedure WndProc(var Message: TMessage); override;
public
procedure ButtonClick;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ButtonClick;
begin
ShowMessage("Click!")
end;

function TForm1.DrawButton(State: Cardinal): boolean;
var
P: TPoint;
R: TRect;
DC: HDC;
Flags: Cardinal;
begin
GetCursorPos(P);
Dec(P.X, Left);
Dec(P.Y, Top);
R.Right := Width - 3 * GetSystemMetrics(SM_CXSMSIZE);
R.Left := R.Right - 75;
R.Top := GetSystemMetrics(SM_CYFRAME) + 2;
R.Bottom := R.Top + GetSystemMetrics(SM_CYSIZE) - 4;
Result := PtInRect(R, P);
if (R.Right > R.Left) and ((State = 0) or Result) then
begin
DC := GetWindowDC(Handle);
try
DrawFrameControl(DC, R, DFC_BUTTON, DFCS_BUTTONPUSH or State);
R.Right := R.Left;
R.Left := GetSystemMetrics(SM_CXFRAME);
Flags := DC_ICON or DC_TEXT;
if GetForegroundWindow = Handle then Flags := Flags or DC_ACTIVE;
DrawCaption(Handle, DC, R, Flags)
finally
ReleaseDC(Handle, DC)
end
end
end;

procedure TForm1.WMNCLButtonDown(var Message: TWMNCLButtonDown);
begin
if DrawButton(DFCS_PUSHED) then SetCapture(Handle) else inherited
end;

procedure TForm1.WMLButtonUp(var Message: TWMLButtonUp);
begin
if GetCapture = Handle then ReleaseCapture;
if DrawButton(0) then ButtonClick else inherited
end;

procedure TForm1.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
WM_ACTIVATE, WM_PAINT, WM_WINDOWPOSCHANGING, WM_SETTEXT, WM_WININICHANGE, WM_CAPTURECHANGED:
DrawButton(0)
end
end;

end.

← →
Matolch. (2003-01-12 14:56) [6]

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

unit Main;

interface

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

type
TMainForm = class(TForm)
private
BtnRect : TRect;
procedure DrawButton(Pushed: boolean = false);
procedure WMNCLButtonDown(var Message: TWMNCLButtonDown ); message WM_NCLBUTTONDOWN;
procedure WMLButtonUp(var Message: TWMLButtonUp ); message WM_LBUTTONUP;
protected
procedure WndProc(var Message: TMessage); override;
public
procedure CaptionButtonClick;
end;

var
MainForm: TMainForm;

implementation {$R *.dfm}

{ TMainForm }

procedure TMainForm.CaptionButtonClick;
begin
ShowMessage("CaptionButtonClick")
end;

procedure TMainForm.WMNCLButtonDown(var Message: TWMNCLButtonDown);
begin
with Message do
if PtInRect(BtnRect, Point(XCursor - Left, YCursor - Top)) then
begin
SetCapture(Handle);
DrawButton(True);
end else inherited;
end;

procedure TMainForm.WMLButtonUp(var Message: TWMLButtonUp);
begin
if GetCapture = Handle then ReleaseCapture;
with Message do
if PtInRect(BtnRect, Point(GetSystemMetrics(SM_CXFRAME)+XPos,-YPos))
then
CaptionButtonClick
else inherited;
end;

procedure TMainForm.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
WM_ACTIVATE, WM_PAINT, WM_SETTEXT, WM_WINDOWPOSCHANGING, WM_SETTINGCHANGE, WM_CAPTURECHANGED: DrawButton;
WM_NCHITTEST:
with TWMNCHitTest(Message) do
if not PtInRect(BtnRect, Point(XPos - Left, YPos - Top)) and (GetCapture = Handle) then DrawButton;
end;
end;

procedure TMainForm.DrawButton(Pushed: boolean = false);
const Flags: array [False..True] of 0..32767 = (0, DFCS_PUSHED or DFCS_CHECKED);
var
R: TRect;
DC: HDC;

procedure DoPaintButton;
begin
with Canvas do
begin
Font.Style := [fsBold];
Brush.Color := clWhite;
FillRect(R);
Brush.Style := bsClear;
TextRect(R, R.Left + 2, R.Top - 1, " *");
end;
end;

function CalcPaintRect(Pushed: boolean = false): TRect;
var D: integer;
begin
Result := BtnRect;
D := Ord(Pushed);
OffsetRect(Result,1+D,1+D);
Dec(Result.Right,3+D);
Dec(Result.Bottom,3+D);
end;

function CalcBtnRect: TRect;
var C: Integer;
begin
C := GetSystemMetrics(SM_CXSIZE);
Result := Bounds(
Width - GetSystemMetrics(SM_CXFRAME) - 4 * C + 2,
GetSystemMetrics(SM_CYFRAME) + 2,
C - 2,
GetSystemMetrics(SM_CYSIZE) - 4);
end;

begin
BtnRect := CalcBtnRect;
R := CalcPaintRect(Pushed);
DC := Canvas.Handle;
with Canvas do
try
Handle := GetWindowDC(Self.Handle);
DrawFrameControl(Handle, BtnRect, DFC_BUTTON, DFCS_BUTTONPUSH or Flags[Pushed]);
DoPaintButton;
finally
ReleaseDC(Self.Handle, Canvas.Handle);
Canvas.Handle := DC;
end;
end;

end.

← →
Matolch. (2003-01-12 15:57) [7]

Сорри, если покоробило кого, не без буга однако:

procedure TMainForm.DrawButton(Pushed: boolean = false);
const Flags: array [False..True] of 0..32767 = (0, DFCS_PUSHED { or DFCS_CHECKED - Deleted});
...

procedure TMainForm.WndProc(var Message: TMessage);
...
case Message.Msg of
WM_ACTIVATE, WM_PAINT, WM_SETTEXT, WM_WINDOWPOSCHANGING, WM_SETTINGCHANGE, {WM_CAPTURECHANGED - Deleted}: ...

← →
Юрий Зотов (2003-01-12 15:57) [8]

> Matolch. (12.01.03 14:56)

Задайте форме длинный-длинный текст в Caption"е и посмотрите, что будет происходить. Сравните со стандартом.

← →
Matolch. (2003-01-12 15:58) [9]

DrawCaption(Handle, DC, R, Flags)?

← →
Юрий Зотов (2003-01-12 16:08) [10]

Конечно.

← →
Matolch. (2003-01-12 16:08) [11]

Но однако в остальном. Глобально у нас два отличия

1. Caption.
2. При уходе с кнопки с нажатой левой кнопкой мыши моя поднимается, ваша остается нажатой.

Я не сомневаюсь, что Вы, при необходимости сделали бы все гораздо лучше. Однако тот нюанс, что не всегда текст в заголовке - длинный.

Однако до этого момента я не понимал, что этот DrawCaption вообще делает, ибо нет документации по этой функции.

← →
Matolch. (2003-01-12 16:11) [12]

Только не смеяться. Вроде того как Draw - рисовать, Caption - ...

← →
Matolch. (2003-01-12 16:19) [13]

Такой вопрос - а нет ли другой функции для прорисовки заголовка, все-таки DrawCaption не совсем правильно его рисует ?

← →
JOHN (2003-01-12 16:40) [14]

Извините! Все работает при двиганиидаже. Я просто ошибся...

← →
Matolch. (2003-01-12 17:15) [15]

DC_ICON or DC_TEXT or DC_GRADIENT

← →
Юрий Зотов (2003-01-12 17:37) [16]

> Matolch.

DrawCaption есть даже в справке по API. Не говоря уже об MSDN.

Насчет нажатой кнопки - этот пример я лет несколько назад набросал в ответ на какой-то вопрос в Королевстве. Буквально за 5 минут, даже и не пытаясь добиться абсолютного идеала. Важно было просто показать, как это делается.

Потом написал компонент на эту тему - вот там уже все как следует.

← →
Matolch. (2003-01-12 17:45) [17]

> Юрий Зотов

DrawCaption я внедрил.
Нашел её, просто не сразу, по F1 вообще не работает, а в Windows написано так:

{!!! doesn"t match help !!!}
{$EXTERNALSYM DrawCaption}
function DrawCaption(p1: HWND; p2: HDC; const p3: TRect; p4: UINT): BOOL; stdcall;

А мне важно было разобраться.
Вы помогли. Спасибо.

← →
Юрий Зотов (2003-01-12 17:47) [18]

The DrawCaption function draws a window caption.

BOOL WINAPI DrawCaption(

HWND hwnd, // handle to window to get text and icon from
HDC hdc, // handle to device context to draw into
LPCRECT lprc, // pointer to rectangle to draw into
UINT uFlags, // set of drawing option flags
);

Parameters

hwnd

Handle to a window that supplies text and an icon for the window caption.

hdc

Handle to a device context. The function draws the window caption into this device context.

lprc

Pointer to a RECT structure that specifies the bounding rectangle for the window caption.

uFlags

A set of bit flags that specify drawing options. You can set zero or more of the following flags:

Value Meaning
DC_ACTIVE The function uses the colors that denote an active caption.
DC_ICON The function draws the icon when drawing the caption text.
DC_INBUTTON The function draws the caption as a button.
DC_SMALLCAP The function draws a small caption, using the current small caption font.
DC_TEXT The function draws the caption text when drawing the caption.

If DC_SMALLCAP is specified, the function draws a normal window caption.

Return Values

If the function succeeds, the return value is nonzero.
If the function fails, the return value is zero.

← →
Юрий Зотов (2003-01-12 17:52) [19]

Дополнительные флаги (из MSDN):

DC_BUTTONS (Whistler)
If set, the function draws the buttons in the caption bar (to minimize, restore, or close an application).

DC_GRADIENT
Windows 98/Me, Windows 2000 or later: When this flag is set, the function uses COLOR_GRADIENTACTIVECAPTION (if the DC_ACTIVE flag was set) or COLOR_GRADIENTINACTIVECAPTION for the title-bar color. If this flag is not set, the function uses COLOR_ACTIVECAPTION or COLOR_INACTIVECAPTION for both colors.

Forms Найти похожие ветки