Distribute keypresses between parent form and child control - delphi

Sometimes a keystroke on a form can have different recipents, depending on the state of the application. See the following sample:
unit Unit1;
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ComCtrls,
Buttons;
type
TForm1 = class(TForm)
private
ListView1: TListView;
ButtonOK: TBitBtn;
ButtonCancel: TBitBtn;
procedure ButtonClick(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
constructor TForm1.Create(AOwner: TComponent);
begin
inherited CreateNew(AOwner);
ClientWidth := 300;
ClientHeight := 240;
ListView1 := TListView.Create(Self);
ListView1.Name := 'ListView1';
ListView1.Parent := Self;
ListView1.Height := 200;
ListView1.Align := alTop;
ListView1.AddItem('aaaaa', nil);
ListView1.AddItem('bbbbb', nil);
ListView1.AddItem('ccccc', nil);
ButtonOK := TBitBtn.Create(Self);
ButtonOK.Parent := Self;
ButtonOK.Left := 8;
ButtonOK.Top := 208;
ButtonOK.Kind := bkOK;
ButtonOK.OnClick := ButtonClick;
ButtonCancel := TBitBtn.Create(Self);
ButtonCancel.Parent := Self;
ButtonCancel.Left := 90;
ButtonCancel.Top := 208;
ButtonCancel.Kind := bkCancel;
ButtonCancel.OnClick := ButtonClick;
end;
procedure TForm1.ButtonClick(Sender: TObject);
begin
ShowMessage((Sender as TBitBtn).Caption);
Application.Terminate;
end;
end.
(To run this, create a standard VCL app and replace the contents of Unit1.pas with the above.)
If one starts the app and presses Enter or Esc, the appropriate button are "clicked". However when one starts editing the listview (by clicking one and a half time on an item) Enter and Esc should accept or cancel the editing which they don't - they still "click" the buttons.
Similar scenarios exist if one has actions with shortcuts F2 or F4 on a form containing a cxGrid, which by default uses these shortcuts to start edit mode or drop down combobox editors.
Do you have an idea how I can continue do use the comfort of TButton.Default/Cancel and actions, while not having to reimplement the key handling of all the components I use?

I guess you have bad luck with the controls you use. TMemo handles it correctly, but indeed an editable TListView does not. The problem seems to originate from win32 rather then the VCL wrapper around it. So it eems that you have to reimplement the key handling on TListView if you do not like its current behavior.
procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
procedure TMyListView.WMGetDlgCode(var Message: TMessage);
begin
inherited;
if IsEditing then
Message.Result := Message.Result or DLGC_WANTALLKEYS;
end;
Since all controls behave different and it is the controls themselves that decide which keys they are interested in, I can't see how you could fix it without having to change unwanted behavior.

Related

Delphi 5: Error asigning click event to TImage

I created an custom control for the TStatusbar.
Its in old Delphi5 for windows.
The goal is, if I click the panel or the image, an event should be raise.
But I get an error by assigning the click event to the image.
The error is in line starts with
_Image.OnClick := ButtonClick;
Can anyone solve this? Thank you!
I modified the code, it works now.
Any suggestions to make it even better?
My main mistake was that I misunderstand
self := TPanelImageButton(template);
I read, that in this case self should inherit all from template.
But I guess this was wrong. So I now set the properties I need in code.
Thank you!
unit PanelImageButton;
{
Usage:
var
PanelUser: TPanelImageButton;
PanelUser :=TPanelImageButton.Create(self,PanelUserTemplate,Image1);
PanelUser.OnClick:= PanelUserClicked;
procedure TForm1.PanelUserClicked(Sender:TObject);
begin
end;
FormClose() -> FreeAndNil(PanelUser);
}
interface
//Delphi: uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,Dialogs, StdCtrls, ExtCtrls;
//Lazarus: uses Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls;
uses
Windows, Messages, Classes, SysUtils, FileUtil, Forms, Controls,
Graphics, Dialogs, StdCtrls, ExtCtrls,{für Fehler}debug;
type
//define usercontrol
TPanelImageButton = class(TPanel)
private
_PanelIndex: integer;
_Image: TImage;
//define event
FOnClick: TNotifyEvent;
procedure ButtonClick(Sender: TObject);
procedure Resizeing(Sender: TObject);
protected
procedure Click; override; //override;//dynamic;
public
constructor Create(TheOwner: TComponent); overload; override;
constructor Create(TheOwner: TComponent; template: TPanel; imageTemplate: TImage);
reintroduce; overload;
destructor Destroy; override;
function HasImage(): boolean;
published
property PanelIndex: integer read _PanelIndex write _PanelIndex;
property OnClick: TNotifyEvent read FOnClick write FOnClick;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('PHOENIX', [TPanelImageButton]);
end;
constructor TPanelImageButton.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
PanelIndex := -1;
_Image := nil;
self.Caption := '';
end;
constructor TPanelImageButton.Create(TheOwner: TComponent;
template: TPanel; imageTemplate: TImage);
begin
inherited Create(TheOwner);
try
PanelIndex := -1;
self.Caption := template.Caption;
self.Color := template.Color;
self.Font := template.Font;
if (assigned(imageTemplate)) then
begin
_Image := TImage.Create(self);
_Image.Picture.Assign(imageTemplate.Picture);
_Image.Transparent := True;
_Image.Parent := self;
_Image.Visible := True;
_Image.AutoSize := False;
_Image.Stretch := True;
_Image.OnClick := ButtonClick;
imageTemplate.Visible := False;
_Image.Cursor := crHandPoint;
end
else
if assigned(_Image) then
FreeAndNil(_Image);
self.OnResize := Resizeing;
//keine Ränder:
self.BevelOuter := bvNone;
self.BevelInner := bvNone;
self.Cursor := crHandPoint;
except
on e: Exception do
WriteDebug('PanelImageButton: ' + e.Message);
end;
end;
destructor TPanelImageButton.Destroy;
begin
try
self.Parent := nil;
if assigned(_Image) then
begin
_Image.parent := nil;
FreeAndNil(_Image);
end;
except
on e: Exception do
WriteDebug('TPanelImageButton.Destroy: ' + e.Message);
end;
inherited;
end;
function TPanelImageButton.HasImage(): boolean;
begin
Result := False;
if assigned(_Image) then
Result := True;
end;
procedure TPanelImageButton.Resizeing(Sender: TObject);
begin
if not (assigned(_Image)) then
exit;
try
_Image.Left := 6;
_Image.Height := self.Height - 12;
_Image.Top := 6;
_Image.Width := _Image.Height;
except
on e: Exception do
WriteDebug('PanelImageButton: ' + e.Message);
end;
end;
procedure TPanelImageButton.ButtonClick(Sender: TObject);
begin
Click;
end;
procedure TPanelImageButton.Click;
begin
try
if Assigned(FOnClick) then
FOnClick(Self);
except
on e: Exception do
WriteDebug('PanelImageButton: ' + e.Message);
end;
end;
end.
I propose that you read up on:
Self - and what it is for and that assigning something else to it basically makes it useless. You could have made it _Image.Parent := template;. But you assigned template to self and then later you do self.OnResize := Resizeing;. Do you want to handle OnResize for this TPanelImageButton (which should have been Self if you did not change it) or do you want to handle OnResize for template? Leave self alone. Use it to access this instance of the class you are currently coding in.
Events - You are trying to free an event variable. Why? It only points to a method. It was not created. Go see how the components that are included with Delphi do events.
# operator - In one of you comments above you do buttonUser.OnClick := #buttonUserClick;. What is that about? The # operator is discussed everywhere. Read up. Its a cool thing but should be used correctly. This blog post is so cool: http://rvelthuis.de/articles/articles-pointers.html
There are some basics that needs to be addressed and I strongly recommend you study how components in Delphi are made.
The last very important thing is for you to include the errors you see into the Stack Overflow question. If you did that we could have given you more specific answers on your particular issue. You would have returned complaining about some other error but at least you would have learned about the first one, hopefully.

PNGImage "Access violation" error at procedure end

I am using PNGImage library in my project, which entire GUI is made up of .png images, which i loaded to TImages at run-time. For some purposes i have to dynamically create plenty of components groups that are similar to each other. Every group consists of some TImages and have a button that lets user proceed to another page with more details about clicked item.
The code i am using:
procedure TMain_Frame.selection_click(Sender: TObject);
var id: string;
begin
id := StringReplace(TLabel(sender).Name, 'label_item_select_', '', [rfReplaceAll]);
hide_created_components; // It does Free all components
show_details(id);
end; // (1)
Access violation error occurs at (1). The odd thing is that it happenes completly random: error may happen at the very first click or may not happen for 10 clicks. If no error occured, F8 leads me inside PNGImage library where some stuff is done. However when error occurs, F7/8 immediately throws it without doing what it has to. This problem happenes only when i go from dynamicaly created objects to static.
CPU window shows that error occured at this ASM code:
movzx ecx, [edi]
ecx value is 755A2E09, edi is 00000000
Is it correct to .Free all dynamically created components? Or should be .Destroy used instead? And why does PNGImage goes inside itself on procedure end;?
Demo:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, pngimage, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
procedure selection_click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure create_label;
var Button: TLabel;
begin
Button := TLabel.Create(Form1);
with Button do
begin
Name := 'dynamic_label_1';
Parent := Form1;
Autosize := false;
Left := 100;
Top := 100;
Width := 150;
Height := 20;
Caption := 'Dynamic Label: Click Me';
BringToFront;
Cursor := crHandPoint;
end;
Button.OnClick := Form1.selection_click;
end;
procedure hide_dyn_label(L: TLabel; mode: boolean);
begin
if mode then
begin
L.Free;
Form1.Image1.Picture.LoadFromFile(PAnsiChar('button_close.png'));
Form1.Image1.Visible := true;
end
else
create_label;
end;
procedure TForm1.selection_click(Sender: TObject);
var id: string;
begin
id := StringReplace(TLabel(Sender).Name, 'dynamic_label_', '', [rfReplaceAll]);
Form1.Button1.Visible := true;
hide_dyn_label(Form1.FindComponent('dynamic_label_1') as TLabel, true);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
create_label;
Form1.Image1.Visible := false;
Form1.Button1.Visible := false;
end;
end.
You are freeing the TLabel while still in its OnClick event handler, Selection_Click which calls hide_dyn_label() which calls L.Free. You can't do that. Use some kind of delayed destruction, f.ex. with a boolean variable FreeDynLabels which you can check in Application.OnIdle. Or post a custom message to the form.

Highlight TPanel on mouse move

I'm trying to make app to show some information, It'll create Panels runtime and place info on it, each panel will be flat as on picture, also app will use runtime themes, so i'd not be able to change panel bg color on mouse move, I tried to place info on TSpeedButton :v O.o it has wonderfull highlight function when it's flat while app is using runtime theme, but the main problem is that images and labels aren't moving when i move speedbutton and i need this much, they just stay there..
I tried to edit TCustomPanel.Paint to see if panel will look like highlighted button, adding code at the end:
PaintRect := ClientRect;
Details := StyleServices.GetElementDetails(ttbButtonHot);
StyleServices.DrawElement(Canvas.Handle, Details, PaintRect);
but with no success..
also it's pretty hard to link some custom code OnClick event at runtime, e.g:
ShowMessage('custom message on each panel');
I have not got any idea on how to do this, hope some one will give me advice or show me some example..
btw, panel will be created this way:
var
P: TPanel;
begin
P := TPanel.Create(Self);
P.Left := 20;
P.Top := 100;
P.Width := 60;
P.Height := 20;
P.Visible := True;
P.Parent := Self;
#P.OnClick := #Showmessageproc; // somehow this way..
end;
App pic:
If i do so:
procedure TMyPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
var
mEvnt: TTrackMouseEvent;
begin
inherited;
if not FMouseTracking then begin
mEvnt.cbSize := SizeOf(mEvnt);
mEvnt.dwFlags := TME_LEAVE;
mEvnt.hwndTrack := Handle;
TrackMouseEvent(mEvnt);
FMouseTracking := True;
showmessage('IN');
end;
end;
procedure TMyPanel.WMMouseLeave(var Msg: TMessage);
begin
if Msg.Msg = WM_MOUSELEAVE then showmessage('OUT');
Msg.Result := 0;
FMouseTracking := False;
if Assigned(FOnMouseLeave) then
FOnMouseLeave(Self);
end;
procedure G(Sender: TObject);
begin
showmessage('message');
end;
procedure TMainFrm.Button1Click(Sender: TObject);
var
P: TMyPanel;
begin
P := TMyPanel.Create(Self);
P.Left := 20;
I := I + 100;
P.Top := I;
P.Width := 200;
P.Height := 80;
P.Visible := True;
P.Parent := Self;
#P.OnClick := #g;
end;
when I move mouse on runtime created panel, 2 msgbox appears, IN and OUT, "mousemove" works fine but "mouse leave" bad, also the mainc question is still actual. the problem is that that I can't get canvas of created panel to draw on. the example above could be achieved more simple way:
#P.OnMouseLeave := #onmouseleaveproc;
#P.OnMouseMove := #onmousemoveproc;
but with Canvas, everything is more difficult, somewhere i've read that canvas is protected in TCustomPanel.
Also there's another question: Is it possible to handle panel wich called e.g OnMouseMove ? because there maybe will be 30 of them (runtime created panels)
I've tried this way: (and it does not works)
type
TMyPanel = class(TPanel)
public
constructor Create(AOwner: TComponent); override;
private
// FMouseTracking: Boolean;
// FOnMouseLeave: TNotifyEvent;
procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
protected
// procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
published
// property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
end;
constructor TMyPanel.Create(AOwner: TComponent);
begin
ControlStyle := ControlStyle - [csParentBackground] + [csOpaque];
inherited;
end;
procedure TMyPanel.CMMouseEnter(var msg: TMessage);
begin
inherited;
Color := clBlue;
{ Do Whatever }
end;
procedure TMyPanel.CMMouseLeave(var msg: TMessage);
begin
inherited;
Color := clRed;
{ Do Whatever }
end;
Simply, color does not changes. (color changes with themes OFF)
It's basically explained here for Delphi 6, but same concept I think. You want to define a custom windows message handler for your panel. This will give you basic mouse enter/exit capability. You can then play with setting TPanel properties from there to find something to your liking. For example, to mock a speed button, you might be able to just set the background color and change the border bevel accordingly. If that isn't adequate, you can write to the TPanel's Canvas directly (paint the behavior that you want to see) on mouse enter/exit to get the visual behavior you're after.
I created the following new component in Delphi and installed it. A new TColorPanel component showed up in a new MyComponents tab in the IDE. I then used this to put a TColorPanel on a new app and it responded properly to the mouse enter/leave events, changing the color as desired. I'm not sure how you made your app's panels as TMyPanel instead of standard TPanel. This is just how I tried it. I used your latest message handling code as-is.
unit ColorPanel;
interface
uses
WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
TColorPanel = class(TPanel)
public
constructor Create(AOwner: TComponent); override;
private
procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
protected
// procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
published
// property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('MyComponents', [TColorPanel]);
end;
constructor TColorPanel.Create(AOwner: TComponent);
begin
ControlStyle := ControlStyle - [csParentBackground] + [csOpaque];
inherited;
end;
procedure TColorPanel.CMMouseEnter(var msg: TMessage);
begin
inherited;
Color := clBlue;
{ Do Whatever }
end;
procedure TColorPanel.CMMouseLeave(var msg: TMessage);
begin
inherited;
Color := clRed;
{ Do Whatever }
end;
end.
I'm not sure why yours isn't working, other than to determine how you declared your app's panels to be TMyPanel.

Delphi Panels and custom component Z order issue

I'm working on a personal project and I have been running into lots of issues lately resulting in many questions, but hey, thats what SO is for right? ;)
Anyhow I tried making a transparent TPanel which I achieved by making a custom component.
The app im making is about world of warcraft and I made a talent calculator like on the official website but in a windows application.
Talents are spells/skills and each talent has information which is displayed in a tooltip.
So I have a tooltip with info,
I have a grid with talents and when I hover on a talent I want to see the info.
Besides that, I want the info to be shown near the position of the cursor.
Almost works. The positioning works, it shows the correct info BUT! here is the problem.
Take a look at this image:
The black semi-transparent panel is my tooltip.
You see the talents (that little 4x6 grid) those are located in a dark grey panel called pnlTalents
The parent of that panel is the lighter grey panel that covers the entire form called Panel1.
The tooltip called TooltipTalent also has the parent Panel1.
I have tried sending pnlTalents to the back and bring TooltipTalent to the front but this made no difference at all.
I even tried TooltipTalent.BringToFront; the moment the position is changed.
Notice how the tooltip has no problem being on top of that darker grey panel at the top of the screen with the speedbuttons.
I compared both panels (the one at the top and the one with the talents) and found no difference in the properties.
I am seriously running out of ideas here. I have no clue what is causing it and how I can solve this problem.
As last resort I tried dropping another transparent panel that covers the entire form to see if that would help but the problem still persisted.
I could also post the code of my custom component but that would be a lot.
If you want to see the code let me know and i'll find a way to show it :)
Can anyone help me on this?
Kind regards
procedure TMyPanel.CreateParams(var params: TCreateParams);
begin
params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT or WS_EX_TOPMOST ;
inherited CreateParams(params);
end;
With a Quickhackcode I get this result
Just as example, Image1 contains a Semitransparent png:
unit Unit4;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, dxGDIPlusClasses;
type
TMyPanel=Class(TPanel)
procedure CreateParams(var params: TCreateParams); override;
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;
End;
TForm4 = class(TForm)
Panel1: TPanel;
Button1: TButton;
Image1: TImage;
Button2: TButton;
CheckBox1: TCheckBox;
Panel2: TPanel;
Button3: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private-Deklarationen }
Fmp:TMyPanel;
fisInPaint:Boolean;
public
{ Public-Deklarationen }
end;
var
Form4: TForm4;
implementation
{$R *.dfm}
{ TMyPanel }
procedure TMyPanel.CreateParams(var params: TCreateParams);
begin
params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT or WS_EX_TOPMOST ;
inherited CreateParams(params);
end;
procedure TMyPanel.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
SetBkMode (msg.DC, TRANSPARENT);
msg.result := 1;
end;
procedure TForm4.Button1Click(Sender: TObject);
begin
Fmp := TMyPanel.Create(self);
With Fmp do
begin
Parent := self;
left:= Panel1.Left -100;
top:= Panel1.top -100;
width := 300;
Height := 300;
end;
image1.Parent := Fmp;
Image1.Align := alClient;
Image1.Stretch := true;
Fmp.BringToFront;
Label1.Parent := FMP;
label1.Transparent := true;
Label1.Left := 100;
Label1.Left := 100;
end;
procedure TForm4.Button3Click(Sender: TObject);
begin
Fmp.Left := fmp.Left + 10;
end;
end.
Can't reproduce problem with XP either:

Delphi Borderless and Captionless Application

I am willing to designed one Application in Delphi XE2 Borderlessly and Captionlessly by using the following code :
BorderIcons = []
BorderStyle = bsNone
But the problem is that there is no Menu on Right Click on the Application on Taskbar just like in the above image. Then I have tried the following codes on FormShow event, but there is also another problem. One Border is created on Left side and Left-Botton side. The codes are :
procedure TForm1.FormShow(Sender: TObject);
var
r: TRect;
begin
r := ClientRect;
OffsetRect(r, 0, GetSystemMetrics(SM_CYCAPTION));
OffsetRect(r, GetSystemMetrics(SM_CXFRAME), GetSystemMetrics(SM_CYFRAME));
SetWindowRgn(Handle,
CreateRectRgn(
r.Left, r.Top,
ClientWidth + r.Left, ClientHeight + r.Top), True);
end;
Please help me.
The simple solution is not to remove the system menu in the first place. Note that the system menu is the official name for the menu that is missing in your app.
Make your .dfm file look like this:
BorderIcons = [biSystemMenu]
BorderStyle = bsNone
Get rid of that FormShow code–it's not needed.
OK, it looks like a stray bit of code from my experimentation was confounding me. Here's what works.
Do exactly what you originally did in your .dfm form:
BorderIcons = []
BorderStyle = bsNone
Then add back the system menu using CreateParams:
TForm1 = class(TForm)
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
...
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.Style := Params.Style or WS_SYSMENU;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
BorderStyle := bsNone;
SetWindowLong(Handle, GWL_STYLE,
WS_POPUP or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_SYSMENU);
SetWindowLong(Handle, GWL_EXSTYLE, WS_EX_CONTROLPARENT or WS_EX_APPWINDOW);
end;
You don't need the code in the OnShow handler with this solution.
The above code can be called any time (not just in OnCreate), it can be used to alter the behavior of a running form for instance (just include WS_VISIBLE to window styles if the form is already visible).
If you want the behavior to be in effect for the life time of the form, it's better to set the flags in an overriden CreateParams (where form styles are applied by VCL). This will also take possible recreation of the form into account. Don't set any form property from the OI for this solution, all of the flags are explicitly set in the code:
type
TForm1 = class(TForm)
..
protected
procedure CreateParams(var Params: TCreateParams); override;
..
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.Style := WS_POPUP or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_SYSMENU;
Params.ExStyle := WS_EX_CONTROLPARENT or WS_EX_APPWINDOW;
end;
You can have a window that appears not to have a caption bar, or a standard caption, by simply taking over the painting of the entire window:
Create a new empty application. Use this code for your form:
unit ncUnit1;
interface
// XE2 uses clause
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs;
// If you're not using XE2 take out the prefixes (WinApi, Vcl, System, etc)
type
TForm1 = class(TForm)
private
{ Private declarations }
public
{ Public declarations }
protected
procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
procedure SolidColorNcPaint(solidColor,frameColor:TColor);
procedure Resizing(State: TWindowState); override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.WMNCPaint(var Message: TWMNCPaint);
begin
SolidColorNcPaint(clBtnFace,clBtnFace);
end;
procedure TForm1.Resizing(State: TWindowState);
begin
inherited;
PostMessage(Self.Handle,WM_NCPAINT,0,0); {force initial paint}
end;
procedure TForm1.SolidColorNcPaint(solidColor,frameColor:TColor);
var
aBorder:Integer;
ahdc : HDC;
begin
aBorder := GetSystemMetrics(SM_CYSIZEFRAME);
canvas.Lock;
ahdc := GetWindowDC(Handle);
canvas.Handle := ahdc;
ExcludeClipRect(canvas.Handle, aBorder, 0, Width-aBorder, Height - aBorder) ;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := frameColor;
Canvas.Pen.Color := solidColor;
Canvas.Rectangle( 0,0, Width,Height);
ReleaseDC(Self.Handle, ahdc);
canvas.Handle := 0;
canvas.Unlock;
end;
end.
What you see above is only enough code to redraw a solid color over the non-client area of the window, not to remove it completely. Depending on the style of custom window you want, you should render whatever you want on the form. If you don't want a Close button then remove the close button, and if you do not want the resizing behaviour, remove the resizing behaviour. If you set the FormStyle=fsDialog plus the above code, you would get a window that has a complete custom drawn title area (which you can put whatever you want into). If you actually don't want the title area to exist at all, you can modify the above code to achieve that too.
You could do what David says and/or also take a look at:
SetWindowRgn API.
If you use just the SetWindowRgn you don't have to remove the TForm's border, just make a rectangle that starts below it.

Resources