Fade in an alpha-blended PNG form in Delphi - delphi

I asked a question about this some years back when Vista was first released, but never resolved the problem and shelved it as something to consider later.
I have a splash screen that I went to great effort to make look great. It's a 32bpp alpha-blended PNG. I have some code (which I can dig up if required!) that works great under Windows XP or under Vista+ when desktop composition is turned off. However, under Vista+ all the transparent parts are black, destroying everything that looks great about it!
So, my question is this: as anyone been able to display a 32bpp alpha-blended PNG as a splash screen in a way that works both with and without desktop composition activated? I'm not adverse to using third-party components if required, free or otherwise.
Ideally, this would work in Delphi 7.
Update: Besides the answers below, which work very well, I found that the TMS TAdvSmoothSplashScreen component also handles this task very well, if somewhat more complex.

Tim, I just tried this on Vista/D2007 with 'Windows Classic' theme selected:
Alpha Blended Splash Screen in Delphi - Part 2
http://melander.dk/articles/alphasplash2/2/
no black background that I could see... it still looks great.

The article Bob S links to gives the correct answer. Since that article contains quite a bit extra information that you actually need, here is the form/unit I create through it (Note that you'll need the GraphicEx library from here:
unit Splash2Form;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, GraphicEx;
type
TSplash2 = class(TForm)
private
{ Private declarations }
procedure PreMultiplyBitmap(Bitmap: TBitmap);
public
constructor Create(Owner: TComponent);override;
{ Public declarations }
procedure CreateParams(var Params: TCreateParams);override;
procedure Execute;
end;
var
Splash2: TSplash2;
implementation
{$R *.dfm}
{ TSplash2 }
constructor TSplash2.Create(Owner: TComponent);
begin
inherited;
Brush.Style := bsClear;
end;
procedure TSplash2.CreateParams(var Params: TCreateParams);
begin
inherited;
end;
procedure TSplash2.Execute;
var exStyle: DWORD;
BitmapPos: TPoint;
BitmapSize: TSize;
BlendFunction: TBlendFunction;
PNG: TPNGGraphic;
Stream: TResourceStream;
begin
// Enable window layering
exStyle := GetWindowLongA(Handle, GWL_EXSTYLE);
if (exStyle and WS_EX_LAYERED = 0) then
SetWindowLong(Handle, GWL_EXSTYLE, exStyle or WS_EX_LAYERED);
PNG := TPNGGraphic.Create;
try
Stream := TResourceStream.Create(HInstance, 'SPLASH', RT_RCDATA);
try
PNG.LoadFromStream(Stream);
finally
Stream.Free;
end;
PreMultiplyBitmap(PNG);
ClientWidth := PNG.Width;
ClientHeight := PNG.Height;
BitmapPos := Point(0, 0);
BitmapSize.cx := ClientWidth;
BitmapSize.cy := ClientHeight;
// Setup alpha blending parameters
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 255;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
// ... and action!
UpdateLayeredWindow(Handle, 0, nil, #BitmapSize, PNG.Canvas.Handle,
#BitmapPos, 0, #BlendFunction, ULW_ALPHA);
Show;
finally
PNG.Free;
end;
end;
procedure TSplash2.PreMultiplyBitmap(Bitmap: TBitmap);
var
Row, Col: integer;
p: PRGBQuad;
PreMult: array[byte, byte] of byte;
begin
// precalculate all possible values of a*b
for Row := 0 to 255 do
for Col := Row to 255 do
begin
PreMult[Row, Col] := Row*Col div 255;
if (Row <> Col) then
PreMult[Col, Row] := PreMult[Row, Col]; // a*b = b*a
end;
for Row := 0 to Bitmap.Height-1 do
begin
Col := Bitmap.Width;
p := Bitmap.ScanLine[Row];
while (Col > 0) do
begin
p.rgbBlue := PreMult[p.rgbReserved, p.rgbBlue];
p.rgbGreen := PreMult[p.rgbReserved, p.rgbGreen];
p.rgbRed := PreMult[p.rgbReserved, p.rgbRed];
inc(p);
dec(Col);
end;
end;
end;
end.

Related

Overlapping TCustomControl objects draw out of order when the form is created/restored

I'm having issues getting a TCustomControl to work with transparency in Delphi 2007. I've currently reduced the problem to the code below. The issue is that when the form is initially created the controls are drawing in the reverse order they are added to the form. When the form is resized, they paint in the correct order. What am I doing wrong? Excluding 3rd party solutions is there a more appropriate path to follow?
Here's my sample project demonstrating the issue in Delphi 2007.
unit Main;
interface
uses
Forms, Classes, Controls, StdCtrls, Messages,
ExtCtrls;
type
// Example of a TWinControl derived control
TMyCustomControl = class(TCustomControl)
protected
procedure CreateParams(var params: TCreateParams); override;
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd);
message WM_ERASEBKGND;
procedure Paint; override;
end;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
YellowBox: TMyCustomControl;
GreenBox: TMyCustomControl;
end;
var
Form1: TForm1;
implementation
uses
Windows, Graphics;
{$R *.dfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
self.OnPaint := FormPaint;
GreenBox := TMyCustomControl.Create(self);
GreenBox.Parent := self;
GreenBox.SetBounds(10,10,200,200);
GreenBox.color := clGreen;
YellowBox := TMyCustomControl.Create(self);
YellowBox.Parent := self;
YellowBox.SetBounds(100,100,200,200);
YellowBox.color := clYellow;
end;
// Paint bars on form background
procedure TForm1.FormPaint(Sender: TObject);
var
Idx: Integer;
begin
for Idx := 0 to ClientHeight div 8 do
begin
if Odd(Idx) then
Canvas.Brush.Color := clWhite
else
Canvas.Brush.Color := clSilver; // pale yellow
Canvas.FillRect(Rect(0, Idx * 8, ClientWidth, Idx * 8 + 8));
end;
end;
{ TMyCustomControl }
procedure TMyCustomControl.CreateParams(var params: TCreateParams);
begin
inherited;
params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT;
end;
procedure TMyCustomControl.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
SetBkMode (msg.DC, TRANSPARENT);
msg.result := 1;
end;
procedure TMyCustomControl.Paint;
begin
Canvas.Brush.Color := color;
Canvas.RoundRect(0,0,width,height,50,50);
end;
end.
What is wrong is your expectancy of the order of painting of your controls. The order of controls receiving WM_PAINT messages is documented to be actually in the exact opposite order, the top-most control receives the message first. More on the documentation later, since having WS_EX_TRANSPARENT styled siblings leaves us in undocumented territory. As you have already noted, you have a case where the order of the controls receiving WM_PAINT messages is not deterministic - when resizing the window the order changes.
I've modified a bit of your reproduction case to see what is happening. The modifications are the inclusion of two panels and a debug output when they receive WM_PAINT.
unit Unit1;
interface
uses
Forms, Classes, Controls, StdCtrls, Messages, ExtCtrls;
type
TMyCustomControl = class(TCustomControl)
protected
procedure CreateParams(var params: TCreateParams); override;
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd);
message WM_ERASEBKGND;
procedure Paint; override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
end;
TPanel = class(extctrls.TPanel)
protected
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
end;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
YellowBox: TMyCustomControl;
GreenBox: TMyCustomControl;
Panel1, Panel2: TPanel;
end;
var
Form1: TForm1;
implementation
uses
sysutils, windows, graphics;
{$R *.dfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
Width := 590;
Height := 270;
OnPaint := FormPaint;
GreenBox := TMyCustomControl.Create(self);
GreenBox.Parent := self;
GreenBox.SetBounds(20, 20, 140, 140);
GreenBox.color := clGreen;
GreenBox.Name := 'GreenBox';
//{
Panel1 := TPanel.Create(Self);
Panel1.Parent := Self;
Panel1.SetBounds(240, 40, 140, 140);
Panel1.ParentBackground := False;
Panel1.Color := clMoneyGreen;
Panel1.Name := 'Panel1';
Panel2 := TPanel.Create(Self);
Panel2.Parent := Self;
Panel2.SetBounds(260, 60, 140, 140);
Panel2.ParentBackground := False;
Panel2.Color := clCream;
Panel2.Name := 'Panel2';
//}
YellowBox := TMyCustomControl.Create(self);
YellowBox.Parent := self;
YellowBox.SetBounds(80, 80, 140, 140);
YellowBox.color := clYellow;
YellowBox.Name := 'YellowBox';
YellowBox.BringToFront;
end;
// Paint bars on form background
procedure TForm1.FormPaint(Sender: TObject);
var
Idx: Integer;
begin
for Idx := 0 to ClientHeight div 8 do
begin
if Odd(Idx) then
Canvas.Brush.Color := clWhite
else
Canvas.Brush.Color := clSilver; // pale yellow
Canvas.FillRect(Rect(0, Idx * 8, ClientWidth, Idx * 8 + 8));
end;
end;
{ TPanel }
procedure TPanel.WMPaint(var Message: TWMPaint);
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
inherited;
end;
{ TMyCustomControl }
procedure TMyCustomControl.CreateParams(var params: TCreateParams);
begin
inherited;
params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT;
end;
procedure TMyCustomControl.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
msg.Result := 1;
end;
procedure TMyCustomControl.WMPaint(var Message: TWMPaint);
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
inherited;
end;
procedure TMyCustomControl.Paint;
begin
Canvas.Brush.Color := Color;
Canvas.RoundRect(0, 0, Width, Height, 50, 50);
end;
end.
Which produces this form:
As determined by order of creation, the z-order is, from bottom to top,
GreenBox,
Panel1,
Panel2,
YellowBox.
The debug output for the WM_PAINT messages is this:
Debug Output: Panel2 painting.. Process Project1.exe (12548)
Debug Output: Panel1 painting.. Process Project1.exe (12548)
Debug Output: YellowBox painting.. Process Project1.exe (12548)
Debug Output: GreenBox painting.. Process Project1.exe (12548)
There are two things worth to note in this order.
First, Panel2 receives the paint message before Panel1, although Panel2 is higher in the z-order.
So how is it that while we see Panel2 as a whole, but we see only part of Panel1 even though it is painted later? This is where update regions come into play. The WS_CLIPSIBLINGS style flags in controls tell the OS that part of a control occupied by a sibling higher in the z-order is not going to be painted.
Clips child windows relative to each other; that is, when a particular
child window receives a WM_PAINT message, the WS_CLIPSIBLINGS
style clips all other overlapping child windows out of the region of
the child window to be updated.
Let's dig into a bit more in the WM_PAINT handler of Panel1 and see how the OS' update region looks like.
{ TPanel }
// not declared in D2007
function GetRandomRgn(hdc: HDC; hrgn: HRGN; iNum: Integer): Integer; stdcall;
external gdi32;
const
SYSRGN = 4;
procedure TPanel.WMPaint(var Message: TWMPaint);
var
PS: TPaintStruct;
Rgn: HRGN;
TestDC: HDC;
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
Message.DC := BeginPaint(Handle, PS);
Rgn := CreateRectRgn(0, 0, 0, 0);
if (Name = 'Panel1') and (GetRandomRgn(Message.DC, Rgn, SYSRGN) = 1) then begin
OffsetRgn(Rgn, - Form1.ClientOrigin.X + Width + 40, - Form1.ClientOrigin.Y);
TestDC := GetDC(Form1.Handle);
SelectObject(TestDC, GetStockObject(BLACK_BRUSH));
PaintRgn(TestDC, Rgn);
ReleaseDC(Form1.Handle, TestDC);
DeleteObject(Rgn);
end;
inherited;
EndPaint(Handle, PS);
end;
The BeginPaint will clip the update region with the system update region which you can then retrieve with GetRandomRgn. I've dumped the clipped update region to the right of the form. Don't mind the Form1 references or missing error checks, we are only debugging. Anyway, this produces the below form:
So, whatever you draw in the client area of Panel1, it will get clipped into the black shape, hence it cannot be visually come into front of Panel2.
Second, remember that the green box is created first, then the panels and then the yellow last. So why is it that the two transparent controls are painted after the two panels?
First, remember that controls are painted from top to bottom. Now, how can it be possible for a transparent control to draw onto something which is drawn after it? Obviously it is not possible. So the entire painting algorithm have to change. There is no documentation on this and the best explanation I've found is from a blog entry of Raymond Chen:
... The WS_EX_TRANSPARENT extended window style alters the painting
algorithm as follows: If a WS_EX_TRANSPARENT window needs to be
painted, and it has any non-WS_EX_TRANSPARENT windows siblings (which
belong to the same process) which also need to be painted, then the
window manager will paint the non-WS_EX_TRANSPARENT windows first.
The top to bottom painting order makes it a difficult one when you have transparent controls. Then there is the case of overlapping transparent controls - which is more transparent than the other? Just accept the fact that overlapping transparent controls produce undetermined behavior.
If you investigate the system update regions of the transparent boxes in the above test case, you'll find both to be exact squares.
Let's shift the panels to in-between the boxes.
procedure TForm1.FormCreate(Sender: TObject);
begin
Width := 590;
Height := 270;
OnPaint := FormPaint;
GreenBox := TMyCustomControl.Create(self);
GreenBox.Parent := self;
GreenBox.SetBounds(20, 20, 140, 140);
GreenBox.color := clGreen;
GreenBox.Name := 'GreenBox';
//{
Panel1 := TPanel.Create(Self);
Panel1.Parent := Self;
Panel1.SetBounds(40, 40, 140, 140);
Panel1.ParentBackground := False;
Panel1.Color := clMoneyGreen;
Panel1.Name := 'Panel1';
Panel2 := TPanel.Create(Self);
Panel2.Parent := Self;
Panel2.SetBounds(60, 60, 140, 140);
Panel2.ParentBackground := False;
Panel2.Color := clCream;
Panel2.Name := 'Panel2';
//}
YellowBox := TMyCustomControl.Create(self);
YellowBox.Parent := self;
YellowBox.SetBounds(80, 80, 140, 140);
YellowBox.color := clYellow;
YellowBox.Name := 'YellowBox';
YellowBox.BringToFront;
end;
...
procedure TMyCustomControl.WMPaint(var Message: TWMPaint);
var
PS: TPaintStruct;
Rgn: HRGN;
TestDC: HDC;
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
Message.DC := BeginPaint(Handle, PS);
Rgn := CreateRectRgn(0, 0, 0, 0);
if (Name = 'GreenBox') and (GetRandomRgn(Message.DC, Rgn, SYSRGN) = 1) then begin
OffsetRgn(Rgn, - Form1.ClientOrigin.X + Width + 260, - Form1.ClientOrigin.Y);
TestDC := GetDC(Form1.Handle);
SelectObject(TestDC, GetStockObject(BLACK_BRUSH));
PaintRgn(TestDC, Rgn);
ReleaseDC(Form1.Handle, TestDC);
DeleteObject(Rgn);
end;
inherited;
EndPaint(Handle, PS);
end;
The right-most black shape is the system update region for the GreenBox. After all the system can apply clipping to a transparent control. I think it would suffice to conclude that the painting algorithm is not perfect when you've got a bunch of transparent controls.
As promised, the documentation quote for the WM_PAINT order. One reason I've left this to last is that it includes a possible solution (of course we already found one solution, scatter some non-transparent controls in-between your transparent controls):
... If a window in the parent chain is composited (a window with
WX_EX_COMPOSITED), sibling windows receive WM_PAINT messages in the
reverse order of their position in the Z order. Given this, the window
highest in the Z order (on the top) receives its WM_PAINT message
last, and vice versa. If a window in the parent chain is not
composited, sibling windows receive WM_PAINT messages in Z order.
For as little as I tested, setting WS_EX_COMPOSITED on the parent form seems to work. But I don't know if it is applicable in your case.

Wrong hint showing on TListView with OwnerData and OwnerDraw set to True

I use Delphi 2007. I have a TListView with OwnerData and OwnerDraw set to True. ViewStyle is set to vsReport.
I have a record.
type TAList=record
Item:Integer;
SubItem1:String;
SubItem2:String;
end;
var
ModuleData: array of TAList;
procedure TForm1.ListView3Data(Sender: TObject; Item: TListItem);
begin
Item.Caption := IntToStr(ModuleData[Item.Index].Item);
Item.SubItems.Add(ModuleData[Item.Index].SubItem1);
Item.SubItems.Add(ModuleData[Item.Index].SubItem2);
end;
procedure TForm1.ListView3DrawItem(Sender: TCustomListView; Item: TListItem; Rect: TRect; State: TOwnerDrawState);
var
LIndex : integer;
LRect: TRect;
LText: string;
TTListView: TListView;
begin
TTListView := TListView(Sender);
if (Item.SubItems[0] = '...') then
begin
TTListView.Canvas.Brush.Color := clHighlight;
TTListView.Canvas.Font.Color := clHighlightText;
end else
begin
TTListView.Canvas.Brush.Color := TTListView.Color;
TTListView.Canvas.Font.Color := TTListView.Font.Color;
end;
for LIndex := 0 to TTListView.Columns.Count - 1 do
begin
if (not(ListView_GetSubItemRect(TTListView.Handle, Item.Index, LIndex, LVIR_BOUNDS, #LRect))) then Continue;
TTListView.Canvas.FillRect(LRect);
if (LIndex = 0) then LText := Item.Caption else LText := Item.SubItems[LIndex - 1];
LRect.Left := LRect.Left + 6;
DrawText(TTListView.Canvas.Handle, PChar(LText), Length(LText), LRect, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX or DT_END_ELLIPSIS);
end;
end;
I wish to show an hint when SubItem2 is truncated. On Windows XP, no hint is shown at all. On Windows Vista & Windows 7, when my mouse is over an item, it shows an hint that is totally off.
I have no special code to handle hints. Should there be one in OwnerData and OwnerDraw modes?
Here are images of what I get:
(source: noelshack.com)
(source: noelshack.com)
EDIT:
David asked why OwnerDraw was set to True. There are two reasons:
This way, I can "disallow" user selection.
If I set OwnerDraw to False, I get another problem. See Why do I get white column separators on my custom-drawn listview?
EDIT 2:
If I handle the OnInfoTip event as suggested by TLama, I get an unthemed balloon hint and the wrong hint from Windows Vista & 7.
1. Environment
Behavior described here I've experienced and tested only on Windows 7 SP1 64-bit Home Premium with most recent updates installed with application built in Delphi 2009 also with latest updates applied. In no other system I've tried this.
2. About the problem
Default item hints that you can see on your screenshot doesn't come from VCL. In certain circumstances whose you just hit, are those hints shown by the system in a wrong, probably somehow cached way. The text of the last item you hovered is shown as a hint for the item you're just hovering. Here is the property configuration (just the important part; the rest I kept in default component values):
ListView1.ShowHint := False;
ListView1.OwnerData := True;
ListView1.OwnerDraw := True;
ListView1.ViewStyle := vsReport;
The following events are handled:
OnData
OnDrawItem
Actually, you don't even need to handle the OnDrawItem to simulate the problem. The hints are shown by the texts given to the items in the OnData event. I'm not able to trace it more deeper, since it seems there's no notification handler (nor even system notification) that might be related to the hints you see in the VCL, which is the reason why I'm suspecting the system.
3. The way to solution
Nothing what I've tried didn't fix the problem keeping your current property configuration. Here's a list of what I've tried:
3.1. Remove the LVS_EX_LABELTIP style ?
As a hot favorite and actually the first what I've checked was excluding the LVS_EX_LABELTIP from the list view's style in a hope the item hint showing will stop and you'll be able to implement your own custom hints through the OnInfoTip event. The problem is, that this style is not implemented anywhere in the list view control, thus it's not included in the list view style.
3.2. Disable the OwnerDraw property ?
Setting the OwnerDraw property to False actually resolves the issue (hints are then shown with correct item texts by the actual hovered item), but you've said you need to use owner drawing, so it's also not a solution for you.
3.3. Remove the LVS_EX_INFOTIP style ?
Removing the LVS_EX_INFOTIP style from the list view's style finally stopped showing of the item hints by the system, but also caused that the control stopped to send to the parent the tooltip notifications. As a consequence of this is the OnInfoTip event with its functionality cutted off. In this case you need to implement the hint handling completely by yourself. And that's what I've tried in the following code.
4. Workaround
I've decided to disable all the system hints of a list view by excluding of the LVS_EX_INFOTIP style and implementing own tooltip handling. So far I know at least about the following problems:
when you use a regular Hint property and hover from an item with shortened caption to the empty area of a list view, the Hint is shown, but it doesn't hide unless you exit the control client rectangle or the hint show time interval elapses (even if you hover an item with shortened caption again). The problem is that I don't know how to specify the CursorRect for the THintInfo structure, so that you cover the whole client rectangle except items area rectangle.
you must use the same item rectangle extents as you use in your owner drawing event method since the system doesn't know, where you're rendering the text of your items. So, another disadvantage is to keep this in sync.
Here is the code of the main unit from a demo project, which you can download from here if you want:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, CommCtrl, StdCtrls;
type
TRecord = record
Item: Integer;
SubItem1: string;
SubItem2: string;
end;
type
TListView = class(ComCtrls.TListView)
private
procedure CMHintShow(var AMessage: TCMHintShow); message CM_HINTSHOW;
end;
type
TForm1 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
procedure ListView1DrawItem(Sender: TCustomListView; Item: TListItem;
Rect: TRect; State: TOwnerDrawState);
procedure ListView1Data(Sender: TObject; Item: TListItem);
private
ModuleData: array of TRecord;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var
ListColumn: TListColumn;
begin
SetLength(ModuleData, 3);
ModuleData[0].Item := 0;
ModuleData[0].SubItem1 := '[0;0] Subitem caption';
ModuleData[0].SubItem2 := '[1;0] Subitem caption';
ModuleData[1].Item := 1;
ModuleData[1].SubItem1 := '[0;1] Subitem caption';
ModuleData[1].SubItem2 := '[1;1] Subitem caption';
ModuleData[2].Item := 2;
ModuleData[2].SubItem1 := '[0;2] This is a long subitem caption';
ModuleData[2].SubItem2 := '[0;2] This is even longer subitem caption';
ListView1.OwnerData := True;
ListView1.OwnerDraw := True;
ListView1.ViewStyle := vsReport;
ListView_SetExtendedListViewStyle(
ListView1.Handle,
ListView_GetExtendedListViewStyle(ListView1.Handle) and not LVS_EX_INFOTIP);
ListColumn := ListView1.Columns.Add;
ListColumn.Caption := 'Col. 1';
ListColumn.Width := 50;
ListColumn := ListView1.Columns.Add;
ListColumn.Caption := 'Col. 2';
ListColumn.Width := 50;
ListColumn := ListView1.Columns.Add;
ListColumn.Caption := 'Col. 3';
ListColumn.Width := 50;
ListView1.Items.Add;
ListView1.Items.Add;
ListView1.Items.Add;
end;
procedure TForm1.ListView1Data(Sender: TObject; Item: TListItem);
begin
Item.Caption := IntToStr(ModuleData[Item.Index].Item);
Item.SubItems.Add(ModuleData[Item.Index].SubItem1);
Item.SubItems.Add(ModuleData[Item.Index].SubItem2);
end;
procedure TForm1.ListView1DrawItem(Sender: TCustomListView; Item: TListItem;
Rect: TRect; State: TOwnerDrawState);
var
R: TRect;
S: string;
SubItem: Integer;
ListView: TListView;
begin
ListView := TListView(Sender);
if (Item.SubItems[0] = '...') then
begin
ListView.Canvas.Brush.Color := clHighlight;
ListView.Canvas.Font.Color := clHighlightText;
end
else
begin
ListView.Canvas.Brush.Color := ListView.Color;
ListView.Canvas.Font.Color := ListView.Font.Color;
end;
for SubItem := 0 to ListView.Columns.Count - 1 do
begin
if ListView_GetSubItemRect(ListView.Handle, Item.Index, SubItem,
LVIR_LABEL, #R) then
begin
ListView.Canvas.FillRect(R);
if (SubItem = 0) then
S := Item.Caption
else
begin
R.Left := R.Left + 6;
S := Item.SubItems[SubItem - 1];
end;
DrawText(ListView.Canvas.Handle, PChar(S), Length(S), R, DT_SINGLELINE or
DT_VCENTER or DT_NOPREFIX or DT_END_ELLIPSIS);
end;
end;
end;
{ TListView }
procedure TListView.CMHintShow(var AMessage: TCMHintShow);
var
R: TRect;
S: string;
Item: Integer;
SubItem: Integer;
HitTestInfo: TLVHitTestInfo;
begin
with AMessage do
begin
HitTestInfo.pt := Point(HintInfo.CursorPos.X, HintInfo.CursorPos.Y);
if ListView_SubItemHitTest(Handle, #HitTestInfo) <> -1 then
begin
Item := HitTestInfo.iItem;
SubItem := HitTestInfo.iSubItem;
if (Item <> -1) and (SubItem <> -1) and
ListView_GetSubItemRect(Handle, Item, SubItem, LVIR_LABEL, #R) then
begin
if (SubItem = 0) then
S := Items[Item].Caption
else
begin
R.Left := R.Left + 6;
S := Items[Item].SubItems[SubItem - 1];
end;
if ListView_GetStringWidth(Handle, PChar(S)) > R.Right - R.Left then
begin
MapWindowPoints(Handle, 0, R.TopLeft, 1);
MapWindowPoints(Handle, 0, R.BottomRight, 1);
HintInfo^.CursorRect := R;
HintInfo^.HintPos.X := R.Left;
HintInfo^.HintPos.Y := R.Top;
HintInfo^.HintMaxWidth := ClientWidth;
HintInfo^.HintStr := S;
AMessage.Result := 0;
end
else
AMessage.Result := 1;
end
else
AMessage.Result := 1;
end
else
inherited;
end;
end;
end.

How to take a screenshot with FireMonkey (multi-platforms)

I haven't find a function to get a screenshot in FMX.Platform (anyway, nowhere else...).
With the VCL, there are many answers (stackoverflow, google, ...).
But how to get a screenshot in an image(bitmap or whatever) for Windows and Mac OS X?
Regards,
W.
Update:
The link from Tipiweb gives a good solution for OS X.
Regarding the Windows part: I have coded this, but I don't like to use the VCL, and a Stream to achieve it...
Any better suggestion, comments?
Thanks.
W.
uses ..., FMX.Types, Winapi.Windows, Vcl.Graphics;
...
function DesktopLeft: Integer;
begin
Result := GetSystemMetrics(SM_XVIRTUALSCREEN);
end;
function DesktopWidth: Integer;
begin
Result := GetSystemMetrics(SM_CXVIRTUALSCREEN);
end;
function DesktopTop: Integer;
begin
Result := GetSystemMetrics(SM_YVIRTUALSCREEN);
end;
function DesktopHeight: Integer;
begin
Result := GetSystemMetrics(SM_CYVIRTUALSCREEN);
end;
procedure GetScreenShot(var dest: FMX.Types.TBitmap);
var
cVCL : Vcl.Graphics.TCanvas;
bmpVCL: Vcl.Graphics.TBitmap;
msBmp : TMemoryStream;
begin
bmpVCL := Vcl.Graphics.TBitmap.Create;
cVCL := Vcl.Graphics.TCanvas.Create;
cVCL.Handle := GetWindowDC(GetDesktopWindow);
try
bmpVCL.Width := DesktopWidth;
bmpVCL.Height := DesktopHeight;
bmpVCL.Canvas.CopyRect(Rect(0, 0, DesktopWidth, DesktopHeight),
cVCL,
Rect(DesktopLeft, DesktopTop, DesktopLeft + DesktopWidth, DesktopTop + DesktopHeight)
);
finally
ReleaseDC(0, cVCL.Handle);
cVCL.Free;
end;
msBmp := TMemoryStream.Create;
try
bmpVCL.SaveToStream(msBmp);
msBmp.Position := 0;
dest.LoadFromStream(msBmp);
finally
msBmp.Free;
end;
I build a small application to take screenshot (Windows / Mac) and it works :-) !
For windows and Mac compatibility, I use a stream.
API Mac Capture --> TStream
API Windows Capture --> Vcl.Graphics.TBitmap --> TStream.
After that, I load my Windows or Mac TStream in a FMX.Types.TBitmap (with load from stream)
Windows Unit code :
unit tools_WIN;
interface
{$IFDEF MSWINDOWS}
uses Classes {$IFDEF MSWINDOWS} , Windows {$ENDIF}, System.SysUtils, FMX.Types, VCL.Forms, VCL.Graphics;
procedure TakeScreenshot(Dest: FMX.Types.TBitmap);
{$ENDIF MSWINDOWS}
implementation
{$IFDEF MSWINDOWS}
procedure WriteWindowsToStream(AStream: TStream);
var
dc: HDC; lpPal : PLOGPALETTE;
bm: TBitMap;
begin
{test width and height}
bm := TBitmap.Create;
bm.Width := Screen.Width;
bm.Height := Screen.Height;
//get the screen dc
dc := GetDc(0);
if (dc = 0) then exit;
//do we have a palette device?
if (GetDeviceCaps(dc, RASTERCAPS) AND RC_PALETTE = RC_PALETTE) then
begin
//allocate memory for a logical palette
GetMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
//zero it out to be neat
FillChar(lpPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
//fill in the palette version
lpPal^.palVersion := $300;
//grab the system palette entries
lpPal^.palNumEntries :=GetSystemPaletteEntries(dc,0,256,lpPal^.palPalEntry);
if (lpPal^.PalNumEntries <> 0) then
begin
//create the palette
bm.Palette := CreatePalette(lpPal^);
end;
FreeMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
end;
//copy from the screen to the bitmap
BitBlt(bm.Canvas.Handle,0,0,Screen.Width,Screen.Height,Dc,0,0,SRCCOPY);
bm.SaveToStream(AStream);
FreeAndNil(bm);
//release the screen dc
ReleaseDc(0, dc);
end;
procedure TakeScreenshot(Dest: FMX.Types.TBitmap);
var
Stream: TMemoryStream;
begin
try
Stream := TMemoryStream.Create;
WriteWindowsToStream(Stream);
Stream.Position := 0;
Dest.LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
{$ENDIF MSWINDOWS}
end.
Mac Unit Code :
unit tools_OSX;
interface
{$IFDEF MACOS}
uses
Macapi.CoreFoundation, Macapi.CocoaTypes, Macapi.CoreGraphics, Macapi.ImageIO,
FMX.Types,
system.Classes, system.SysUtils;
procedure TakeScreenshot(Dest: TBitmap);
{$ENDIF MACOS}
implementation
{$IFDEF MACOS}
{$IF NOT DECLARED(CGRectInfinite)}
const
CGRectInfinite: CGRect = (origin: (x: -8.98847e+30; y: -8.98847e+307);
size: (width: 1.79769e+308; height: 1.79769e+308));
{$IFEND}
function PutBytesCallback(Stream: TStream; NewBytes: Pointer;
Count: LongInt): LongInt; cdecl;
begin
Result := Stream.Write(NewBytes^, Count);
end;
procedure ReleaseConsumerCallback(Dummy: Pointer); cdecl;
begin
end;
procedure WriteCGImageToStream(const AImage: CGImageRef; AStream: TStream;
const AType: string = 'public.png'; AOptions: CFDictionaryRef = nil);
var
Callbacks: CGDataConsumerCallbacks;
Consumer: CGDataConsumerRef;
ImageDest: CGImageDestinationRef;
TypeCF: CFStringRef;
begin
Callbacks.putBytes := #PutBytesCallback;
Callbacks.releaseConsumer := ReleaseConsumerCallback;
ImageDest := nil;
TypeCF := nil;
Consumer := CGDataConsumerCreate(AStream, #Callbacks);
if Consumer = nil then RaiseLastOSError;
try
TypeCF := CFStringCreateWithCharactersNoCopy(nil, PChar(AType), Length(AType),
kCFAllocatorNull); //wrap the Delphi string in a CFString shell
ImageDest := CGImageDestinationCreateWithDataConsumer(Consumer, TypeCF, 1, AOptions);
if ImageDest = nil then RaiseLastOSError;
CGImageDestinationAddImage(ImageDest, AImage, nil);
if CGImageDestinationFinalize(ImageDest) = 0 then RaiseLastOSError;
finally
if ImageDest <> nil then CFRelease(ImageDest);
if TypeCF <> nil then CFRelease(TypeCF);
CGDataConsumerRelease(Consumer);
end;
end;
procedure TakeScreenshot(Dest: TBitmap);
var
Screenshot: CGImageRef;
Stream: TMemoryStream;
begin
Stream := nil;
ScreenShot := CGWindowListCreateImage(CGRectInfinite,
kCGWindowListOptionOnScreenOnly, kCGNullWindowID, kCGWindowImageDefault);
if ScreenShot = nil then RaiseLastOSError;
try
Stream := TMemoryStream.Create;
WriteCGImageToStream(ScreenShot, Stream);
Stream.Position := 0;
Dest.LoadFromStream(Stream);
finally
CGImageRelease(ScreenShot);
Stream.Free;
end;
end;
{$ENDIF MACOS}
end.
In your mainForm unit :
...
{$IFDEF MSWINDOWS}
uses tools_WIN;
{$ELSE}
uses tools_OSX;
{$ENDIF MSWINDOWS}
...
var
imgDest: TImageControl;
...
TakeScreenshot(imgDest.Bitmap);
If you have another idea, please talk to me :-)
Thanks to Tipiweb's code (in his answer), a github project has been started based on it; with some improvements (ability to take a screenshot only of a certain window, or take a full screenshot).
The unit is named xscreenshot.pas (single unit for all platforms)
The github project page:
https://github.com/z505/screenshot-delphi
The utilities available in this unit:
// take screenshot of full screen
procedure TakeScreenshot(...)
// take screenshot only of a specific window
procedure TakeWindowShot(...)
Finishing touches on MacOS need some work for taking a screenshot of a specific window.
Again, thanks to Tipiweb and his answer to get this project started.
You can use a good solution from this site to do a Mac OSX screenshot.
Do the same works with the Windows API like this:
procedure ScreenShot(x, y, Width, Height: integer; bm: TBitMap);
var
dc: HDC; lpPal : PLOGPALETTE;
begin
{test width and height}
if ((Width = 0) OR (Height = 0)) then exit;
bm.Width := Width;
bm.Height := Height;
//get the screen dc
dc := GetDc(0);
if (dc = 0) then exit;
//do we have a palette device?
if (GetDeviceCaps(dc, RASTERCAPS) AND RC_PALETTE = RC_PALETTE) then
begin
//allocate memory for a logical palette
GetMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
//zero it out to be neat
FillChar(lpPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
//fill in the palette version
lpPal^.palVersion := $300;
//grab the system palette entries
lpPal^.palNumEntries :=GetSystemPaletteEntries(dc,0,256,lpPal^.palPalEntry);
if (lpPal^.PalNumEntries <> 0) then
begin
//create the palette
bm.Palette := CreatePalette(lpPal^);
end;
FreeMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
end;
//copy from the screen to the bitmap
BitBlt(bm.Canvas.Handle,0,0,Width,Height,Dc,x,y,SRCCOPY);
//release the screen dc
ReleaseDc(0, dc);
end;
After that, include your different units with:
uses
{$IFDEF MSWINDOWS}
mytools_win,
{$ENDIF MSWINDOWS}
{$IFDEF MACOS}
mytools_mac,
{$ENDIF MACOS}

Fade all other windows of an application when a dialog is shown?

How to dim / fade all other windows of an application in Delphi 2009.
Form has an AlphaBlend property, but it controls only transparency level. But it would be nice if we can have something like this
(Concentrated window) . Even stackoverflow.com does that, when we try to insert a link/ image etc in the post.
How can we achieve this in a delphi application?
Here is a unit I just knocked together for you.
To use this unit drop a TApplication component on your main form and in the OnModalBegin call _GrayForms and then in the OnModalEnd call the _NormalForms method.
This is a very simple example and could be made to be more complex very easily. Checking for multiple call levels etc....
For things like system (open, save, etc) dialogs you can wrap the dialog execute method in a try...finally block calling the appropriate functions to get a similar reaction.
This unit should work on Win2k, WinXP, Vista and should even work on Win7.
Ryan.
unit GrayOut;
interface
procedure _GrayForms;
procedure _GrayDesktop;
procedure _NormalForms;
implementation
uses windows, classes, forms, Contnrs, Types, Graphics, sysutils;
var
gGrayForms : TComponentList;
procedure _GrayDesktop;
var
loop : integer;
wScrnFrm : TForm;
wForm : TForm;
wPoint : TPoint;
begin
if not assigned(gGrayForms) then
begin
gGrayForms := TComponentList.Create;
gGrayForms.OwnsObjects := true;
for loop := 0 to Screen.MonitorCount - 1 do
begin
wForm := TForm.Create(nil);
gGrayForms.Add(wForm);
wForm.Position := poDesigned;
wForm.AlphaBlend := true;
wForm.AlphaBlendValue := 64;
wForm.Color := clBlack;
wForm.BorderStyle := bsNone;
wForm.Enabled := false;
wForm.BoundsRect := Screen.Monitors[loop].BoundsRect;
SetWindowPos(wForm.handle, HWND_TOP, 0,0,0,0, SWP_NOSIZE or SWP_NOMOVE);
wForm.Visible := true;
end;
end;
end;
procedure _GrayForms;
var
loop : integer;
wScrnFrm : TForm;
wForm : TForm;
wPoint : TPoint;
wScreens : TList;
begin
if not assigned(gGrayForms) then
begin
gGrayForms := TComponentList.Create;
gGrayForms.OwnsObjects := true;
wScreens := TList.create;
try
for loop := 0 to Screen.FormCount - 1 do
wScreens.Add(Screen.Forms[loop]);
for loop := 0 to wScreens.Count - 1 do
begin
wScrnFrm := wScreens[loop];
if wScrnFrm.Visible then
begin
wForm := TForm.Create(wScrnFrm);
gGrayForms.Add(wForm);
wForm.Position := poOwnerFormCenter;
wForm.AlphaBlend := true;
wForm.AlphaBlendValue := 64;
wForm.Color := clBlack;
wForm.BorderStyle := bsNone;
wForm.Enabled := false;
wForm.BoundsRect := wScrnFrm.BoundsRect;
SetWindowLong(wForm.Handle, GWL_HWNDPARENT, wScrnFrm.Handle);
SetWindowPos(wForm.handle, wScrnFrm.handle, 0,0,0,0, SWP_NOSIZE or SWP_NOMOVE);
wForm.Visible := true;
end;
end;
finally
wScreens.free;
end;
end;
end;
procedure _NormalForms;
begin
FreeAndNil(gGrayForms);
end;
initialization
gGrayForms := nil;
end.
I have done something similar for showing a modal form trying to keep the implementation as simple as possible. I don't know if this will fit your needs, but here it is:
function ShowModalDimmed(Form: TForm; Centered: Boolean = true): TModalResult;
var
Back: TForm;
begin
Back := TForm.Create(nil);
try
Back.Position := poDesigned;
Back.BorderStyle := bsNone;
Back.AlphaBlend := true;
Back.AlphaBlendValue := 192;
Back.Color := clBlack;
Back.SetBounds(0, 0, Screen.Width, Screen.Height);
Back.Show;
if Centered then begin
Form.Left := (Back.ClientWidth - Form.Width) div 2;
Form.Top := (Back.ClientHeight - Form.Height) div 2;
end;
result := Form.ShowModal;
finally
Back.Free;
end;
end;
I'm not sure about the "right" way to do it, but in order to "fade-to-white", what you can do is place your form in another completely white form (white background color, no controls).
So when your form is in 0% transparency, it will show as a regular form, but when it's in 50% transparency it will be faded to white. You can obviously choose other colors as your background.
I'm looking forward to seeing other answers...
EDIT: after seeing your "Jedi Concentrate" link, it seems that a dark-gray background will mimic the Expose effect better.
One way to do this is to place another form behind your dialog, this form would have no borders, and would contain a single image. This image would be a capture of the entire desktop from just before the dialog popped up, then run through a transform to lower the luminosity of each pixel by 50%. One trick that works quite well here is to use a black form, and to only include ever other pixel. If you know for certain that you will have theme support, you can optionally use a completely black form and use the alphablend and alphablendvalue properties..this will allow the OS to perform the luminosity transformation for you. An alphablendvalue of 128 is = 50%.
EDIT
As mghie pointed out, there is the possibility of a user pressing alt-tab to switch to another application. One way to handle this scenario would be to hide the "overlay" window in the application.OnDeactivate event, and to show it on the application.OnActivate event. Just remember to set the zorder of the overlay window lower than your modal dialog.
I created a similar effect to the Jedi Concentrate with a Form sized to the Screen.WorkArea with Color := clBlack and BorderStyle := bsNone
I found setting the AlphaBlendValue was too slow to animate nicely, so I use SetLayeredWindowAttributes()
The unit's code:
unit frmConcentrate;
{$WARN SYMBOL_PLATFORM OFF}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TFadeThread = class(TThread)
private
fForm: TForm;
public
constructor Create(frm: TForm);
procedure Execute; override;
end;
TConcentrateFrm = class(TForm)
procedure FormDestroy(Sender: TObject);
procedure FormClick(Sender: TObject);
private
{ Private declarations }
fThread: TFadeThread;
public
{ Public declarations }
end;
procedure StartConcentrate(aForm: TForm = nil);
var
ConcentrateFrm: TConcentrateFrm;
implementation
{$R *.dfm}
procedure StartConcentrate(aForm: TForm = nil);
var
Hnd: HWND;
begin
try
if not Assigned(ConcentrateFrm) then
ConcentrateFrm := TConcentrateFrm.Create(nil)
else
Exit;
ConcentrateFrm.Top := Screen.WorkAreaTop;
ConcentrateFrm.Left := Screen.WorkAreaLeft;
ConcentrateFrm.Width := Screen.WorkAreaWidth;
ConcentrateFrm.Height := Screen.WorkAreaHeight;
Hnd := GetForegroundWindow;
SetWindowLong(ConcentrateFrm.Handle, GWL_EXSTYLE,
GetWindowLong(ConcentrateFrm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED
);
SetLayeredWindowAttributes(
ConcentrateFrm.Handle,
ColorToRGB(clBlack),
0,
LWA_ALPHA
);
ConcentrateFrm.Show;
if Assigned(aForm) then
aForm.BringToFront
else
SetForegroundWindow(Hnd);
ConcentrateFrm.fThread := TFadeThread.Create(ConcentrateFrm);
Application.ProcessMessages;
ConcentrateFrm.fThread.Resume;
except
FreeAndNil(ConcentrateFrm);
end;
end;
procedure TConcentrateFrm.FormClick(Sender: TObject);
var
p: TPoint;
hnd: HWND;
begin
GetCursorPos(p);
ConcentrateFrm.Hide;
hnd := WindowFromPoint(p);
while GetParent(hnd) 0 do
hnd := GetParent(hnd);
SetForegroundWindow(hnd);
Release;
end;
procedure TConcentrateFrm.FormDestroy(Sender: TObject);
begin
ConcentrateFrm := nil;
end;
{ TFadeThread }
constructor TFadeThread.Create(frm: TForm);
begin
inherited Create(true);
FreeOnTerminate := true;
Priority := tpIdle;
fForm := frm;
end;
procedure TFadeThread.Execute;
var
i: Integer;
begin
try
// let the main form open before doing this intensive process.
Sleep(300);
i := 0;
while i < 180 do
begin
if not Win32Check(
SetLayeredWindowAttributes(
fForm.Handle,
ColorToRGB(clBlack),
i,
LWA_ALPHA
)
) then
begin
RaiseLastOSError;
end;
Sleep(10);
Inc(i, 4);
end;
except
end;
end;
end.

What is the best way to make a Delphi Application completely full screen?

What is the best way to make a delphi application (delphi 2007 for win32 here) go completely full screen, removing the application border and covering windows task bar ?
I am looking for something similar to what IE does when you hit F11.
I wish this to be a run time option for the user not a design time decision by my good self.
As Mentioned in the accepted answer
BorderStyle := bsNone;
was part of the way to do it. Strangely I kept getting a E2010 Incompatible types: 'TFormBorderStyle' and 'TBackGroundSymbol' error when using that line (another type had bsNone defined).
To overcome this I had to use :
BorderStyle := Forms.bsNone;
Well, this has always worked for me. Seems a bit simpler...
procedure TForm52.Button1Click(Sender: TObject);
begin
BorderStyle := bsNone;
WindowState := wsMaximized;
end;
A Google search turned up the following, additional methods:
(though I think I'd try Roddy's method first)
Manually fill the screen (from: About Delphi)
procedure TSomeForm.FormShow(Sender: TObject) ;
var
r : TRect;
begin
Borderstyle := bsNone;
SystemParametersInfo
(SPI_GETWORKAREA, 0, #r,0) ;
SetBounds
(r.Left, r.Top, r.Right-r.Left, r.Bottom-r.Top) ;
end;
Variation on a theme by Roddy
FormStyle := fsStayOnTop;
BorderStyle := bsNone;
Left := 0;
Top := 0;
Width := Screen.Width;
Height := Screen.Height;
The WinAPI way (by Peter Below from TeamB)
private // in form declaration
Procedure WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo);
message WM_GETMINMAXINFO;
Procedure TForm1.WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo);
Begin
inherited;
With msg.MinMaxInfo^.ptMaxTrackSize Do Begin
X := GetDeviceCaps( Canvas.handle, HORZRES ) + (Width - ClientWidth);
Y := GetDeviceCaps( Canvas.handle, VERTRES ) + (Height - ClientHeight
);
End;
End;
procedure TForm1.Button2Click(Sender: TObject);
Const
Rect: TRect = (Left:0; Top:0; Right:0; Bottom:0);
FullScreen: Boolean = False;
begin
FullScreen := not FullScreen;
If FullScreen Then Begin
Rect := BoundsRect;
SetBounds(
Left - ClientOrigin.X,
Top - ClientOrigin.Y,
GetDeviceCaps( Canvas.handle, HORZRES ) + (Width - ClientWidth),
GetDeviceCaps( Canvas.handle, VERTRES ) + (Height - ClientHeight ));
// Label2.caption := IntToStr(GetDeviceCaps( Canvas.handle, VERTRES ));
End
Else
BoundsRect := Rect;
end;
Maximize the form and hide the title bar. The maximize line is done from memory, but I'm pretty sure WindowState is the property you want.
There's also this article, but that seems too complicated to me.
procedure TForm1.FormCreate(Sender: TObject) ;
begin
//maximize the window
WindowState := wsMaximized;
//hide the title bar
SetWindowLong(Handle,GWL_STYLE,GetWindowLong(Handle,GWL_STYLE) and not WS_CAPTION);
ClientHeight := Height;
end;
Edit: Here's a complete example, with "full screen" and "restore" options. I've broken out the different parts into little procedures for maximum clarity, so this could be greatly compressed into just a few lines.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
btnGoFullScreen: TButton;
btnNotFullScreen: TButton;
btnShowTitleBar: TButton;
btnHideTitleBar: TButton;
btnQuit: TButton;
procedure btnGoFullScreenClick(Sender: TObject);
procedure btnShowTitleBarClick(Sender: TObject);
procedure btnHideTitleBarClick(Sender: TObject);
procedure btnNotFullScreenClick(Sender: TObject);
procedure btnQuitClick(Sender: TObject);
private
SavedLeft : integer;
SavedTop : integer;
SavedWidth : integer;
SavedHeight : integer;
SavedWindowState : TWindowState;
procedure FullScreen;
procedure NotFullScreen;
procedure SavePosition;
procedure HideTitleBar;
procedure ShowTitleBar;
procedure RestorePosition;
procedure MaximizeWindow;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btnQuitClick(Sender: TObject);
begin
Application.Terminate;
end;
procedure TForm1.btnGoFullScreenClick(Sender: TObject);
begin
FullScreen;
end;
procedure TForm1.btnNotFullScreenClick(Sender: TObject);
begin
NotFullScreen;
end;
procedure TForm1.btnShowTitleBarClick(Sender: TObject);
begin
ShowTitleBar;
end;
procedure TForm1.btnHideTitleBarClick(Sender: TObject);
begin
HideTitleBar;
end;
procedure TForm1.FullScreen;
begin
SavePosition;
HideTitleBar;
MaximizeWindow;
end;
procedure TForm1.HideTitleBar;
begin
SetWindowLong(Handle,GWL_STYLE,GetWindowLong(Handle,GWL_STYLE) and not WS_CAPTION);
ClientHeight := Height;
end;
procedure TForm1.MaximizeWindow;
begin
WindowState := wsMaximized;
end;
procedure TForm1.NotFullScreen;
begin
RestorePosition;
ShowTitleBar;
end;
procedure TForm1.RestorePosition;
begin
//this proc uses what we saved in "SavePosition"
WindowState := SavedWindowState;
Top := SavedTop;
Left := SavedLeft;
Width := SavedWidth;
Height := SavedHeight;
end;
procedure TForm1.SavePosition;
begin
SavedLeft := Left;
SavedHeight := Height;
SavedTop := Top;
SavedWidth := Width;
SavedWindowState := WindowState;
end;
procedure TForm1.ShowTitleBar;
begin
SetWindowLong(Handle,gwl_Style,GetWindowLong(Handle,gwl_Style) or ws_Caption or ws_border);
Height := Height + GetSystemMetrics(SM_CYCAPTION);
Refresh;
end;
end.
Put to the form onShow event such code:
WindowState:=wsMaximized;
And to the OnCanResize this:
if (newwidth<width) and (newheight<height) then
Resize:=false;
How to constrain a sub-form within the Mainform like it was an MDI app., but without the headaches! (Note: The replies on this page helped me get this working, so that's why I posted my solution here)
private
{ Private declarations }
StickyAt: Word;
procedure WMWINDOWPOSCHANGING(Var Msg: TWMWINDOWPOSCHANGING); Message M_WINDOWPOSCHANGING;
Procedure WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
later...
procedure TForm2.WMWINDOWPOSCHANGING(var Msg: TWMWINDOWPOSCHANGING);
var
A, B: Integer;
iFrameSize: Integer;
iCaptionHeight: Integer;
iMenuHeight: Integer;
begin
iFrameSize := GetSystemMetrics(SM_CYFIXEDFRAME);
iCaptionHeight := GetSystemMetrics(SM_CYCAPTION);
iMenuHeight := GetSystemMetrics(SM_CYMENU);
// inside the Mainform client area
A := Application.MainForm.Left + iFrameSize;
B := Application.MainForm.Top + iFrameSize + iCaptionHeight + iMenuHeight;
with Msg.WindowPos^ do
begin
if x <= A + StickyAt then
x := A;
if x + cx >= A + Application.MainForm.ClientWidth - StickyAt then
x := (A + Application.MainForm.ClientWidth) - cx + 1;
if y <= B + StickyAt then
y := B;
if y + cy >= B + Application.MainForm.ClientHeight - StickyAt then
y := (B + Application.MainForm.ClientHeight) - cy + 1;
end;
end;
and yet more...
Procedure TForm2.WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo);
var
iFrameSize: Integer;
iCaptionHeight: Integer;
iMenuHeight: Integer;
Begin
inherited;
iFrameSize := GetSystemMetrics(SM_CYFIXEDFRAME);
iCaptionHeight := GetSystemMetrics(SM_CYCAPTION);
iMenuHeight := GetSystemMetrics(SM_CYMENU);
With msg.MinMaxInfo^.ptMaxPosition Do
begin
// position of top when maximised
X := Application.MainForm.Left + iFrameSize + 1;
Y := Application.MainForm.Top + iFrameSize + iCaptionHeight + iMenuHeight + 1;
end;
With msg.MinMaxInfo^.ptMaxSize Do
Begin
// width and height when maximized
X := Application.MainForm.ClientWidth;
Y := Application.MainForm.ClientHeight;
End;
With msg.MinMaxInfo^.ptMaxTrackSize Do
Begin
// maximum size when maximised
X := Application.MainForm.ClientWidth;
Y := Application.MainForm.ClientHeight;
End;
// to do: minimum size (maybe)
End;
In my case, the only working solution is:
procedure TFormHelper.FullScreenMode;
begin
BorderStyle := bsNone;
ShowWindowAsync(Handle, SW_MAXIMIZE);
end;
You need to make sure Form position is poDefaultPosOnly.
Form1.Position := poDefaultPosOnly;
Form1.FormStyle := fsStayOnTop;
Form1.BorderStyle := bsNone;
Form1.Left := 0;
Form1.Top := 0;
Form1.Width := Screen.Width;
Form1.Height := Screen.Height;
Tested and works on Win7 x64.
Try:
Align = alClient
FormStyle = fsStayOnTop
This always align to the primary monitor;
Hm. Looking at the responses I seem to remember dealing with this about 8 years ago when I coded a game. To make debugging easier, I used the device-context of a normal, Delphi form as the source for a fullscreen display.
The point being, that DirectX is capable of running any device context fullscreen - including the one allocated by your form.
So to give an app "true" fullscreen capabilities, track down a DirectX library for Delphi and it will probably contain what you need out of the box.

Resources