Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.
Dismiss

Button on the caption of window

80 views
Skip to first unread message

Sergey Kirichenko

unread,
Sep 4, 2003, 6:30:24 PM9/4/03
to
Hi,
How I can make a custom button on the caption of window? Like and near a
system's Min, Max and Close?
Keep in mind, it make by API's function.
Thanx.
~~~~~~~~~~~~~~~~~~
Best regards,
Sergey Kirichenko


Charles Hacker

unread,
Sep 4, 2003, 10:45:14 PM9/4/03
to
Sergey Kirichenko wrote:
>
> How I can make a custom button on the caption of window? Like and near a

Take a look at TCaptionControl by Yorai Aminov's.
It allows you to add additional buttons to the caption.

It was downloaded as CAPCTRL.ZIP from
http://ourworld.compuserve.com/homepages/yaminov/downloads.htm

Not sure if it is still there.
Do an internet serach for this.

--
Charles Hacker
Lecturer in Electronics and Computing
School of Engineering
Griffith University - Gold Coast
Australia

Rimvydas Paulavicius

unread,
Sep 5, 2003, 2:08:14 AM9/5/03
to
Sergey Kirichenko wrote:

unit TitleBtn;
{Tips:
1. by Brendan Delumpa on 3/19/97
2. by Ralph Friedman
}
interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes,
Graphics, Forms, Dialogs, Buttons, Controls, StdCtrls, ExtCtrls;

type
TTitleBtnForm = class( TForm )
procedure FormResize( Sender: TObject );
procedure FormCreate( Sender: TObject );
function GetSystemTitleBtnCount: integer;
procedure KillHint;
private
TitleButton: TRect;
FActive: boolean;
FHint: THintWindow;
Timer2: TTimer;
procedure DrawTitleButton( i: integer );
{Paint-related messages}
procedure WMSetText( var Msg: TWMSetText); message WM_SETTEXT;
procedure WMNCPaint( var Msg: TWMNCPaint); message WM_NCPAINT;
procedure WMNCActivate( var Msg: TWMNCActivate); message WM_NCACTIVATE;
{Mouse-related messages}
procedure WMNCHitTest( var Msg: TWMNCHitTest ); message WM_NCHitTest;
procedure WMNCLButtonDown( var Msg: TWMNCLButtonDown); message
WM_NCLBUTTONDOWN;
procedure WMNCLButtonUp( var Msg: TWMNCLButtonUp); message
WM_NCLBUTTONUP;
procedure WMNCMouseMove( var Msg: TWMNCMouseMove ); message
WM_NCMouseMove;
procedure FormMouseMove( Sender: TObject; Shift: TShiftState; X, Y:
Integer );
{-}
function GetVerInfo: DWORD;
{-}
procedure ShowHint;
procedure Timer2Timer( Sender: TObject );
public
end;

const
htTitleBtn = htSizeLast+1;

implementation

uses
PauLitaData, About, SpoolMessages;

procedure TTitleBtnForm.FormResize( Sender: TObject );
begin
Perform( WM_NCACTIVATE, Word(Active), 0 );
end;{ TTitleBtnForm.FormResize }

procedure TTitleBtnForm.DrawTitleButton( i: integer );
var
bmap: TBitmap; {Bitmap to be drawn - 16x16: 16 Colors}
XFrame, {X and Y size of Sizeable area of Frame}
YFrame,
XTtlBit, {X and Y size of Bitmaps in caption}
YTtlBit: integer;
n: integer;
begin
bmap := NIL;
{Get size of form frame and bitmaps in title bar}
XFrame := GetSystemMetrics( SM_CXFRAME );
YFrame := GetSystemMetrics( SM_CYFRAME );
XTtlBit := GetSystemMetrics( SM_CXSIZE );
YTtlBit := GetSystemMetrics( SM_CYSIZE );
n := GetSystemTitleBtnCount;
case Win32MajorVersion of
5: //Win2K/XP
case Win32MinorVersion of
0: begin {Windows 2000}
TitleButton := Bounds( Width-XFrame-(n+1)*XTtlBit+1-2,
YFrame+1, XTtlBit-2, YTtlBit-4);
end;
1: begin {Windows XP or .NET server}
TitleButton := Bounds( Width-((n+1)*XTtlBit), YFrame+1,
XTtlBit-4, YTtlBit-4)
end;
end;{ Win32MinorVersion }
else begin
TitleButton := Bounds( Width-XFrame-(n+1)*XTtlBit+1, YFrame+1,
XTtlBit-2{+2}, YTtlBit-4{+2});
end;
end;{ Win32MajorVersion }
Canvas.Handle := GetWindowDC( Self.Handle) ;
try
{Draw a button face on the TRect}
DrawButtonFace( Canvas, TitleButton, 1, bsAutoDetect, FALSE, FALSE,
FALSE );
bmap := TBitmap.Create;
DataModule1.ImageList1.GetBitmap( i, bmap );
with TitleButton do begin
case Win32MajorVersion of
5: //Win2K/XP
case Win32MinorVersion of
0: begin {Windows 2000}
Canvas.StretchDraw( TitleButton, bmap );
{Canvas.Draw( Left, Top, bmap )}
end;
1: begin {Windows XP or .NET server}
Canvas.Draw( Left+2, Top+2, bmap )
end;
end;{ Win32MinorVersion }
else begin
Canvas.StretchDraw( TitleButton, bmap );
end;
end;{ Win32MajorVersion }
end;{ TitleButton }
finally
ReleaseDC( Self.Handle, Canvas.Handle );
if bmap <> NIL then
bmap.Free;
Canvas.Handle := 0;
end;
end;{ TTitleBtnForm.DrawTitleButton }

procedure TTitleBtnForm.WMSetText( var Msg: TWMSetText);
begin
inherited;
DrawTitleButton( 0 );
end;{ TTitleBtnForm.WMSetText }

procedure TTitleBtnForm.WMNCPaint( var Msg: TWMNCPaint);
begin
inherited;
DrawTitleButton( 0 );
end;{ TTitleBtnForm.WMNCPaint }

procedure TTitleBtnForm.WMNCActivate( var Msg: TWMNCActivate);
begin
inherited;
DrawTitleButton( 0 );
end;{ TTitleBtnForm.WMNCActivate }

procedure TTitleBtnForm.WMNCLButtonDown( var Msg: TWMNCLButtonDown);
begin
inherited;
if (Msg.HitTest = htTitleBtn) then
DrawTitleButton( 1 );
end;{ TTitleBtnForm.WMNCLButtonDown }

procedure TTitleBtnForm.WMNCLButtonUp( var Msg: TWMNCLButtonUp );
begin
inherited;
if (Msg.HitTest = htTitleBtn) then begin
KillHint;
ShowAboutBox;
end;
end;{ TTitleBtnForm.WMNCLButtonUp }

procedure TTitleBtnForm.WMNCMouseMove( var Msg: TWMNCMouseMove );
begin
inherited;
if (Msg.HitTest = htTitleBtn)
and PtinRect( TitleButton, Point(Msg.XCursor-Left, Msg.YCursor-Top))
then
ShowHint
else
KillHint;
end;{ TTitleBtnForm.WMNCMouseMove }

function TTitleBtnForm.GetVerInfo: DWORD;
var
verinfo: TOSVERSIONINFO;
begin
verinfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if GetVersionEx( verinfo ) then
Result := verinfo.dwPlatformID
else
Result := 0;
{Returns:
VER_PLATFORM_WIN32s - Win32s on Windows 3.1
VER_PLATFORM_WIN32_WINDOWS - on Windows95
VER_PLATFORM_WIN32_NT - on WindowsNT
}
end;{ TTitleBtnForm.GetVerInfo }

procedure TTitleBtnForm.WMNCHitTest( var Msg: TWMNCHitTest );
begin
inherited;
with Msg do begin
if PtinRect( TitleButton, Point(XPos-Left, YPos-Top)) then
Result := htTitleBtn;
end;{ Msg }
end;{ TTitleBtnForm.WMNCHitTest }

function TTitleBtnForm.GetSystemTitleBtnCount: integer;
var
Menu: HMenu;
i, n, m, l: integer;
begin
l := 0;
Menu := GetSystemMenu( Handle, FALSE );
n := GetMenuItemCount( Menu );
for i := 0 to n-1 do begin
m := GetMenuItemID( Menu, i );
if (m = SC_RESTORE)
or (m = SC_MAXIMIZE)
or (m = SC_CLOSE)
then
Inc( l )
else if (m = SC_MINIMIZE) then
Inc( l, 2 );
end;{ i }
Result := l;
end;{ TTitleBtnForm.GetSystemTitleBtnCount }

procedure TTitleBtnForm.KillHint;
begin
if Assigned( Timer2 ) then begin
Timer2.Enabled := FALSE;
Timer2.Free;
Timer2 := NIL;
end;
if Assigned( FHint ) then begin
FHint.ReleaseHandle;
FHint.Free;
FHint := NIL;
end;
FActive := FALSE;
end;{ TTitleBtnForm.KillHint }

procedure TTitleBtnForm.Timer2Timer( Sender: TObject );
var
thePoint: TPoint;
theRect: TRect;
Count: DWORD;
i: integer;
begin
Timer2.Enabled := FALSE;
Timer2.Free;
Timer2 := NIL;
thePoint.X := TitleButton.Left;
thePoint.Y := TitleButton.Bottom-25;
with theRect do begin
topLeft := ClientToScreen( thePoint );
Right := Left+Canvas.TextWidth( MsgAbout )+10;
Bottom := Top+14;
end;
FHint := THintWindow.Create( Self );
Fhint.Color := clInfoBk;
FHint.ActivateHint( theRect, MsgAbout );
for i := 1 to 7 do begin
Count := GetTickCount;
repeat
{Application.ProcessMessages;}
until (GetTickCount - Count >= 18);
with theRect do begin
Inc( Top );
Inc( Bottom );
FHint.SetBounds( Left, Top, FHint.Width, FHint.Height );
FHint.Update;
end;
end;{ i }
FActive := TRUE;
end;{ TTitleBtnForm.Timer2Timer }

procedure TTitleBtnForm.ShowHint;
begin
if FActive then Exit;
if Assigned( Timer2 ) then Exit;
Timer2 := TTimer.Create( Self );
Timer2.Interval := 500;
Timer2.OnTimer := Timer2Timer;
Timer2.Enabled := TRUE;
end;{ TTitleBtnForm.Show }

procedure TTitleBtnForm.FormMouseMove( Sender: TObject;
Shift: TShiftState; X, Y: Integer );
begin
inherited;
KillHint;
end;{ TTitleBtnForm.FormMouseMove }

procedure TTitleBtnForm.FormCreate( Sender: TObject );
begin
OnMouseMove := FormMouseMove;
end;{ TTitleBtnForm.FormCreate }

end.


Sergey Kirichenko

unread,
Sep 5, 2003, 5:43:50 AM9/5/03
to
Hi,
I remember it: by "DrawFrameControl(hdc, rect, DFC_BUTTON, DFCS_BUTTONPUSH)"
But! DrawFrameControl make an OLD style button. How to make an XP-style
(rounded) caption buttons?

Mike Shkolnik

unread,
Sep 5, 2003, 6:57:15 AM9/5/03
to
Open a theme (OpenThemeData(0, 'Button') ) and draw a button
(DrawThemeBackground+BP_PUSHBUTTON). After that close a theme
(CloseThemeData)

--
With best regards, Mike Shkolnik
EMail: mshk...@scalabium.com
http://www.scalabium.com


"Sergey Kirichenko" <k...@NOSPAM.cheerful.com> сообщил/сообщила в новостях
следующее: news:3f58...@newsgroups.borland.com...

Yorai Aminov (TeamB)

unread,
Sep 5, 2003, 11:24:20 PM9/5/03
to
On Fri, 5 Sep 2003 22:43:50 +1300, "Sergey Kirichenko"
<k...@NOSPAM.cheerful.com> wrote:

>DrawFrameControl make an OLD style button. How to make an XP-style
>(rounded) caption buttons?

Take a look at
http://develop.shorterpath.com/ZoneArticles/VisualStyles.asp.

---
Yorai Aminov (TeamB)
http://develop.shorterpath.com/yorai
(TeamB cannot answer questions received via email.)

0 new messages