How to make my own dialog component from Firemonkey TPopUp? - delphi

[Delphi XE5 Up2]
I am trying to use TPopUp to inherit and create a component, following the same idea as exposed on the Flyouts demo for the CalendarFlyout. I will be not using the Calendar, but I want that space free so that I can place any other FMX component that I want.
I have made the component using the new component wizard and added some controls:
unit PopupTest;
interface
uses
System.SysUtils, System.Classes, FMX.Types, FMX.Controls,
FMX.Layouts, FMX.StdCtrls;
type
TPopupTest = class(TPopup)
private
FPanel : TPanel;
FLayoutButton : TLayout;
FCloseButton : TButton;
FSaveButton : TButton;
FClientArea : TLayout;
protected
procedure OnClose(Sender: TObject);
procedure OnSave(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TPopupTest]);
end;
{ TPopupTest }
constructor TPopupTest.Create(AOwner: TComponent);
begin
inherited;
FPanel := TPanel.Create(self);
FPanel.Position.X := 0;
FPanel.Position.Y := 0;
FPanel.Margins.Left := 10;
FPanel.Margins.Right := 10;
FPanel.Margins.Top := 10;
FPanel.Margins.Bottom := 10;
FPanel.StyleLookup := 'flyoutpanel';
FPanel.Align := TAlignLayout.alClient;
FPanel.Visible := True;
FLayoutButton := TLayout.Create(FPanel);
FLayoutButton.Align := TAlignLayout.alBottom;
FLayoutButton.Height := 22;
FCloseButton := TButton.Create(FLayoutButton);
FCloseButton.Align := TAlignLayout.alLeft;
FCloseButton.StyleLookup := 'flyoutbutton';
FCloseButton.Text := 'Fechar';
FCloseButton.OnClick := OnClose;
FSaveButton := TButton.Create(FLayoutButton);
FSaveButton.Align := TAlignLayout.alLeft;
FSaveButton.StyleLookup := 'flyoutbutton';
FSaveButton.Text := 'Salvar';
FSaveButton.OnClick := OnSave;
FClientArea := TLayout.Create(FPanel);
FClientArea.Align := TAlignLayout.alClient;
Width := 100;
Height := 100;
end;
destructor TPopupTest.Destroy;
begin
FClientArea.Free;
FCloseButton.Free;
FSaveButton.Free;
FLayoutButton.Free;
FPanel.Free;
inherited;
end;
procedure TPopupTest.OnClose(Sender: TObject);
begin
end;
procedure TPopupTest.OnSave(Sender: TObject);
begin
end;
end.
I have made several tests and nothing appears, just the popup itself, nothing inside. I am using the MetropoliUI style and the Styles on the component for the inner controls are based on that style.
For simplicity I have remove everything else and compiled and tested.
I am using the TPopUp for several reasons, but the main one is that my "dialog" will be inserted on the form, and I will add to it some TEdits that will be connected by LiveBinding to the same DataSet etc on the form. So no need to create another form with everything else, and preserve all the context (at least I believe this is the right thing to do)
What I am looking for:
What is missing to make all the internal controls appear
How to make sure that the FClientArea, that is a TLayout will be available for the user to add other controls on it?
The final result would like this:
Where in the middle area is a TLayout where I could drop other controls like TEdit.

When you create the TPopupTest in your form you have to set the creator's owner to your Form, as well as the Parent.
Changing the Unit to something like this will make it appear but it's not exactly as you picture it, you will have to refine it a bit. Also my solution might not be the best but at least you will get to see something now.
constructor TPopupTest.Create(AOwner: TComponent);
var
PopPanel: TPanel;
PopLayout: TLayout;
PopClose: TButton;
PopSave: TButton;
PopClientArea: TLayout;
begin
inherited;
PopPanel := TPanel.Create(Owner);
PopPanel.Position.X := 0;
PopPanel.Position.Y := 0;
PopPanel.Margins.Left := 10;
PopPanel.Margins.Right := 10;
PopPanel.Margins.Top := 10;
PopPanel.Margins.Bottom := 10;
PopPanel.StyleLookup := 'flyoutpanel';
PopPanel.Parent := Owner as TFmxObject;
PopPanel.Align := TAlignLayout.alClient;
PopPanel.Visible := True;
PopLayout := TLayout.Create(Owner);
PopLayout.Parent := PopPanel;
PopLayout.Align := TAlignLayout.alBottom;
PopLayout.Height := 22;
PopClose := TButton.Create(Owner);
PopClose.Parent := PopLayout;
PopClose.Align := TAlignLayout.alLeft;
PopClose.StyleLookup := 'flyoutbutton';
PopClose.Text := 'Fechar';
PopClose.OnClick := OnClose;
PopSave := TButton.Create(Owner);
PopSave.Parent := PopLayout;
PopSave.Align := TAlignLayout.alLeft;
PopSave.StyleLookup := 'flyoutbutton';
PopSave.Text := 'Salvar';
PopSave.OnClick := OnSave;
PopClientArea := TLayout.Create(Owner);
PopClientArea.Parent := PopPanel;
PopClientArea.Align := TAlignLayout.alClient;
FPanel:= PopPanel;
FLayoutButton:= PopLayout;
FSaveButton:= PopSave;
FCloseButton:= PopClose;
FClientArea:= PopClientArea;
Width := 100;
Height := 100;
end;

Related

FireMonkey tRectangle with tLabel child

I am coding a custom control based on tRectangle:
tMyRect = class (tRectangle)
On the tMyRect Constructor, I create a tLabel:
fRectLabel := tLabel.Create (Self);
and then set some properties for it.
At runtime, the tLabel is not showed according to the properties settings, neither responds to the speedkey.
Follows the complete code:
unit frmMyRect;
interface
uses FMX.Controls, FMX.Controls.Presentation, FMX.Forms, FMX.Layouts,
FMX.Objects, FMXFMX.StdCtrls, FMX.Types,System.Classes, System.UITypes;
type
tfrmMyRect = class (tForm)
procedure FormCreate (Sender: tObject);
end;
tMyRect = class (tRectangle)
fRectLabel : tLabel;
constructor Create (aOwner: tComponent);
end;
var formMyRect: tfrmMyRect;
implementation
{$R *.fmx}
var MyRect : tMyRect;
procedure tformMyRect.FormCreate (Sender: tObject);
begin
MyRect := tMyRect.Create (Self);
MyRect.Parent := frmMyRect;
end; { FormCreate }
constructor tMyRect.Create (aOwner: tComponent);
begin
inherited;
Align := tAlignLayout.Center;
CanFocus := True;
Height := 23;
Width := 80;
fRectLabel := tLabel.Create (Self);
with fRectLabel do begin
Align := tAlignLayout.Center;
AutoSize := True;
FocusControl := Self;
HitTest := True;
Parent := Self;
Text := 'Labe&l';
with TextSettings do begin
FontColor := TAlphaColorRec.Blue;
WordWrap := False;
Font.Style := [TFontStyle.fsBold];
end;
end;
end; { Create }
end.
I appreciate if someone can clarify why the tLabel does not behave as expected.
You need to alter the StyleSettings property of the TLabel so that the styling system does not apply those that you have changed, e.g.:
StyledSettings := StyledSettings - [TStyledSetting.FontColor, TStyledSetting.Style];
As to the "neither responds to the speedkey" part, you'll need to clarify what you mean, as you have not shown code related to that

How to create a dialog like component that allows drop other controls inside it?

It is a Firemonkey component, however I could see that most of the component base is the same for VCL and FMX, so please if you know how to do that in VCL share your knowledge, it can be eventually the solution for my case.
I am using a TPopup as the ancestor. It is convenient for me since it remains on the form/frame and I can wire it with LiveBindings using the same context/structure of the parent, this is very convenient for me.
I need it behave exactly it is the TPopup, as a container. But I need it looks better and have my specific buttons (I have created some properties and automations for my software inside it)
The problem is that I create some internal controls, like TLayouts, Tpanels and Tbuttons to make looks like this: (empty)
That black area inside it is where I want to drop controls like TEdit and others.
I have set all the internal created controls to Store = false, so it is not getting stored on the streaming system. Doing that when I drop a TEdit for example, what I get is this (Tedit with aligned=top I need this):
However I was expecting this:
If I change the Store = true I can get the right effect, but all the inside controls are exposed on the Structure panel and every time I save the form and reopen everything gets duplicated. The inside components exposed is not a problem for me, but the duplication is, if I close and open the component 10 times I will get the entire inside structure replicated 10 time.
I will try to show some code that is related to the design of the component:
Class declaration:
[ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32 or pidiOSSimulator or pidiOSDevice or pidAndroid)]
TNaharFMXPopup = class(TPopup, INaharControlAdapter, INaharControl)
private
protected
FpnlMain : TPanel;
FlytToolBar : TLayout;
FbtnClose : TButton;
FbtnSave : TButton;
FbtnEdit : TButton;
FpnlClientArea : TPanel;
FlblTitle : TLabel;
procedure Loaded; override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
constructor Create:
constructor TNaharFMXPopup.Create(AOwner: TComponent);
begin
inherited;
FpnlMain := TPanel.Create(Self);
FlblTitle := TLabel.Create(Self);
FlytToolBar := TLayout.Create(Self);
FbtnEdit := TButton.Create(Self);
FpnlClientArea := TPanel.Create(Self);
FbtnClose := TButton.Create(FlytToolBar);
FbtnSave := TButton.Create(FlytToolBar);
Height := 382;
Placement := TPlacement.Center;
StyleLookup := 'combopopupstyle';
Width := 300;
ApplyControlsProp;
end;
Setting properties of the internal controls:
procedure TNaharFMXPopup.ApplyControlsProp;
begin
with FpnlMain do
begin
Parent := Self;
Align := TAlignLayout.Client;
StyleLookup := 'grouppanel';
TabOrder := 0;
Margins.Bottom := 10;
Margins.Left := 10;
Margins.Right := 10;
Margins.Top := 10;
Stored := false;
end;
with FlblTitle do
begin
Parent := FpnlMain;
Text := 'Título';
Align := TAlignLayout.Top;
Height := 36;
StyleLookup := 'flyouttitlelabel';
Stored := false;
end;
with FpnlClientArea do
begin
Parent := FpnlMain;
Align := TAlignLayout.Client;
StyleLookup := 'gridpanel';
TabOrder := 0;
Margins.Bottom := 5;
Margins.Left := 5;
Margins.Right := 5;
Margins.Top := 5;
Stored := false;
end;
with FlytToolBar do
begin
Parent := FpnlMain;
Align := TAlignLayout.Bottom;
Height := 50;
Stored := false;
end;
with FbtnClose do
begin
Parent := FlytToolBar;
Text := 'Fecha';
Align := TAlignLayout.Left;
Height := 50;
StyleLookup := 'tilebutton';
TabOrder := 0;
Width := 70;
ModalResult := mrClose;
Stored := false;
end;
with FbtnEdit do
begin
Parent := FlytToolBar;
Text := '';//'Edita';
Align := TAlignLayout.Left;
Height := 50;
StyleLookup := 'tilebutton';
TabOrder := 1;
Width := 70;
ModalResult := mrContinue;
Stored := false;
Enabled := false;
end;
with FbtnSave do
begin
Parent := FlytToolBar;
Text := 'Salva';
Align := TAlignLayout.Left;
Height := 50;
StyleLookup := 'tilebutton';
TabOrder := 2;
Width := 70;
ModalResult := mrOk;
Stored := false;
end;
end;
Loaded:
procedure TNaharFMXPopup.Loaded;
begin
inherited;
ApplyControlsProp;
SetEvents;
end;
I have tried the following with notification, trying to make the inserted control a parent for my intenal "clientarea"
procedure TNaharFMXPopup.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited;
if (Operation = opInsert) and (csDesigning in ComponentState) then
begin
if AComponent.Owner = self then
if AComponent is TFmxObject then
begin
(AComponent as TFmxObject).Parent := FpnlClientArea;
end;
end;
end;
But that made nothing change.
I have asked similar question before, but I was not aware of many things on creating such a component and the answer I got gave little help, I was missing the Parent of each internal component.
Now I am trying to really show where is my need: I need to drop controls on my TPopup dialog that will be parented of the ClientArea inside it.
Take a closer look at TTabControl / TTabItem in the unit FMX.TabControl. This is your perfect example because it basically needs to solve the same problem.
The following function is what you need to override:
procedure DoAddObject(const AObject: TFmxObject); override;
This is called when a control is added to your control. Override this function so that your control is added to the FpnlClientArea control instead. You'd get something similar to this:
procedure TNaharFMXPopup.DoAddObject(const AObject: TFmxObject);
// ...
begin
if (FpnlClientArea <> nil) and not AObject.Equals(FpnlClientArea) and not AObject.Equals(ResourceLink) then
begin
FpnlClientArea.AddObject(AObject);
end
else
inherited;
end;
Make sure that AObject.Equals also excludes your other "not stored" controls.
Without the DoAddObject override, the FMX TabControl would show the same problem as your component currently has.
The TPopup is not intended to accept controls. So that needs a few more tricks.
Here's a modified version of your unit that works for me. I've added a few comments:
unit NaharFMXPopup;
interface
uses
System.UITypes,
System.Variants,
System.SysUtils, System.Classes, FMX.Types, FMX.Controls, FMX.Layouts, FMX.StdCtrls;
type
[ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32 or pidiOSSimulator or pidiOSDevice or pidAndroid)]
TNaharFMXPopup = class(TPopup)
private
procedure ApplyControlsProp;
protected
FpnlMain : TPanel;
FlytToolBar : TLayout;
FbtnClose : TButton;
FbtnSave : TButton;
FbtnEdit : TButton;
FpnlClientArea : TContent; // change to TContent.
// For TPanel we'd have to call SetAcceptControls(False),
// but that is not easily possible because that is protected
FlblTitle : TLabel;
procedure Loaded; override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure DoAddObject(const AObject: TFmxObject); override;
public
procedure InternalOnClose(Sender: TObject);
procedure InternalOnSave(Sender: TObject);
procedure InternalOnEdit(Sender: TObject);
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure SetEvents;
published
end;
implementation
{ TNaharFMXPopup }
constructor TNaharFMXPopup.Create(AOwner: TComponent);
begin
inherited;
FpnlMain := TPanel.Create(Self);
FlblTitle := TLabel.Create(Self);
FlytToolBar := TLayout.Create(Self);
FbtnEdit := TButton.Create(Self);
FpnlClientArea := TContent.Create(Self); // change to TContent
FbtnClose := TButton.Create(FlytToolBar);
FbtnSave := TButton.Create(FlytToolBar);
Height := 382;
Placement := TPlacement.Center;
StyleLookup := 'combopopupstyle';
Width := 300;
// A TPopup is not intended to accept controls
// so we have to undo those restrictions:
Visible := True;
SetAcceptsControls(True);
ApplyControlsProp;
end;
destructor TNaharFMXPopup.Destroy;
begin
inherited;
end;
procedure TNaharFMXPopup.ApplyControlsProp;
begin
with FpnlMain do
begin
Parent := Self;
Align := TAlignLayout.Bottom;
StyleLookup := 'grouppanel';
TabOrder := 0;
Height := 50;
Margins.Bottom := 10;
Margins.Left := 10;
Margins.Right := 10;
Margins.Top := 10;
Stored := false;
end;
with FpnlClientArea do
begin
Parent := Self; // we have to change this to Self (it refuses working if the parent is FPnlMain)
Align := TAlignLayout.Client;
Margins.Left := 3;
Margins.Right := 3;
Margins.Top := 3;
Margins.Bottom := 3;
Stored := false;
end;
with FlytToolBar do
begin
Parent := FpnlMain;
Align := TAlignLayout.Bottom;
Height := 50;
Stored := false;
end;
with FbtnClose do
begin
Parent := FlytToolBar;
Text := 'Close';
Align := TAlignLayout.Left;
Height := 50;
StyleLookup := 'tilebutton';
TabOrder := 0;
Width := 70;
ModalResult := mrClose;
Stored := false;
end;
with FbtnEdit do
begin
Parent := FlytToolBar;
Text := '';//'Edita';
Align := TAlignLayout.Left;
Height := 50;
StyleLookup := 'tilebutton';
TabOrder := 1;
Width := 70;
ModalResult := mrContinue;
Stored := false;
Enabled := false;
end;
with FbtnSave do
begin
Parent := FlytToolBar;
Text := 'Save';
Align := TAlignLayout.Left;
Height := 50;
StyleLookup := 'tilebutton';
TabOrder := 2;
Width := 70;
ModalResult := mrOk;
Stored := false;
end;
end;
procedure TNaharFMXPopup.Loaded;
begin
inherited;
ApplyControlsProp;
// SetEvents;
end;
procedure TNaharFMXPopup.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
end;
procedure TNaharFMXPopup.InternalOnClose(Sender: TObject);
begin
end;
procedure TNaharFMXPopup.InternalOnEdit(Sender: TObject);
begin
end;
procedure TNaharFMXPopup.InternalOnSave(Sender: TObject);
begin
end;
procedure TNaharFMXPopup.SetEvents;
begin
FbtnClose.OnClick := InternalOnClose;
FbtnSave.OnClick := InternalOnSave;
FbtnEdit.OnClick := InternalOnEdit;
end;
procedure TNaharFMXPopup.DoAddObject(const AObject: TFmxObject);
begin
//inherited; try commenting the block bellow and uncommenting this one
//Exit;
if (FpnlClientArea <> nil)
and not AObject.Equals(FpnlClientArea)
and not AObject.Equals(ResourceLink)
and not AObject.Equals(FpnlMain)
and not AObject.Equals(FlblTitle)
and not AObject.Equals(FlytToolBar)
and not AObject.Equals(FbtnEdit)
and not AObject.Equals(FpnlClientArea)
and not AObject.Equals(FbtnClose)
and not AObject.Equals(FbtnSave) then
begin
FpnlClientArea.AddObject(AObject);
end
else
inherited;
end;
end.

Performance issues re-sizing large amount of components on form resize

I feel my failure so far lies in search terms as information on this has to be pretty common. Basically I am looking for common solutions and best practices when performing resizes on several components while a form is resized.
I have a form with a component that is based upon TScrollBox. The ScrollBox contains rows which are added dynamically at run time. They are basically a subcomponent. Each one has an image on the left and a memo on the right. The height is set based upon the width and aspect ratio of the image. Upon the resize of the scroll box a loop sets the width of the rows triggering the rows own internal resize. The loop also sets the relative top position if the heights have changed.
Screen shot:
Around 16 rows performs fine. My goal is closer to 32 rows which is very choppy and can peg a core at 100% usage.
I have tried:
Added a check to prevent a new resize starting while the previous has yet to complete. It answered if it occured and it does sometimes.
I tried preventing it resizing more often than every 30 ms which would allow for 30 frame per second drawing. Mixed results.
Changed the rows base component from TPanel to TWinControl. Not sure if there is a performance penalty using the Panel but its an old habit.
With and without double buffering.
I would like to allow row resizing to occur during a resize as a preview to how large the image will be in the row. That eliminates one obvious solution that in some applications is an acceptable loss.
Right now the resize code internally for the row is completely dynamic and based upon the dimensions of each image. Next thing I plan to try is to basically specify the Aspect Ratio, Max Width/Height based on the largest image in the collection. This should reduce the amount of math per row. But it seems like the issues are more the resize event and the loop itself?
Full unit code for the components:
unit rPBSSVIEW;
interface
uses
Classes, Controls, Forms, ExtCtrls, StdCtrls, Graphics, SysUtils, rPBSSROW, Windows, Messages;
type
TPBSSView = class(TScrollBox)
private
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ResizeRows(Sender: TObject);
procedure AddRow(FileName: String);
procedure FillRow(Row: Integer; ImageStream: TMemoryStream);
end;
var
PBSSrow: Array of TPBSSRow;
Resizingn: Boolean;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TScrollBox]);
end;
procedure TPBSSView.AddRow(FileName: String);
begin
SetLength(PBSSrow,(Length(PBSSrow) + 1));
PBSSrow[Length(PBSSrow)-1] := TPBSSRow.create(self);
With PBSSrow[Length(PBSSrow)-1] do
begin
Left := 2;
if (Length(PBSSrow)-1) = 0 then Top := 2 else Top := ((PBSSRow[Length(PBSSRow) - 2].Top + PBSSRow[Length(PBSSRow) - 2].Height) + 2);
Width := (inherited ClientWidth - 4);
Visible := True;
Parent := Self;
PanelLeft.Caption := FileName;
end;
end;
procedure TPBSSView.FillRow(Row: Integer; ImageStream: TMemoryStream);
begin
PBSSRow[Row].LoadImageFromStream(ImageStream);
end;
procedure TPBSSView.ResizeRows(Sender: TObject);
var
I, X: Integer;
begin
if Resizingn then exit
else
begin
Resizingn := True;
HorzScrollBar.Visible := False;
X := (inherited ClientWidth - 4);
if Length(PBSSrow) > 0 then
for I := 0 to Length(PBSSrow) - 1 do
Begin
PBSSRow[I].Width := X; //Set Width
if not (I = 0) then //Move all next ones down.
begin
PBSSRow[I].Top := (PBSSRow[(I - 1)].Top + PBSSRow[(I - 1)].Height) + 2;
end;
Application.ProcessMessages;
End;
HorzScrollBar.Visible := True;
Resizingn := False;
end;
end;
constructor TPBSSView.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
OnResize := ResizeRows;
DoubleBuffered := True;
VertScrollBar.Tracking := True;
Resizingn := False;
end;
destructor TPBSSView.Destroy;
begin
inherited;
end;
end.
Row Code:
unit rPBSSROW;
interface
uses
Classes, Controls, Forms, ExtCtrls, StdCtrls, Graphics, pngimage, SysUtils;
type
TPBSSRow = class(TWinControl)
private
FImage: TImage;
FPanel: TPanel;
FMemo: TMemo;
FPanelLeft: TPanel;
FPanelRight: TPanel;
FImageWidth: Integer;
FImageHeight: Integer;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure MyPanelResize(Sender: TObject);
procedure LeftPanelResize(Sender: TObject);
published
procedure LoadImageFromStream(ImageStream: TMemoryStream);
property Image: TImage read FImage;
property Panel: TPanel read FPanel;
property PanelLeft: TPanel read FPanelLeft;
property PanelRight: TPanel read FPanelRight;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TWinControl]);
end;
procedure TPBSSRow.MyPanelResize(Sender: TObject);
begin
if (Width - 466) <= FImageWidth then FPanelLeft.Width := (Width - 466)
else FPanelLeft.Width := FImageWidth;
FPanelRight.Width := (Width - FPanelLeft.Width);
end;
procedure TPBSSRow.LeftPanelResize(Sender: TObject);
var
AspectRatio: Extended;
begin
FPanelRight.Left := (FPanelLeft.Width);
//Enforce Info Minimum Height or set Height
if FImageHeight > 0 then AspectRatio := (FImageHeight/FImageWidth) else
AspectRatio := 0.4;
if (Round(AspectRatio * FPanelLeft.Width)) >= 212 then
begin
Height := (Round(AspectRatio * FPanelLeft.Width));
FPanelLeft.Height := Height;
FPanelRight.Height := Height;
end
else
begin
Height :=212;
FPanelLeft.Height := Height;
FPanelRight.Height := Height;
end;
if Fimage.Height >= FImageHeight then FImage.Stretch := False else Fimage.Stretch := True;
if Fimage.Width >= FImageWidth then FImage.Stretch := False else Fimage.Stretch := True;
end;
procedure TPBSSRow.LoadImageFromStream(ImageStream: TMemoryStream);
var
P: TPNGImage;
n: Integer;
begin
P := TPNGImage.Create;
ImageStream.Position := 0;
P.LoadFromStream(ImageStream);
FImage.Picture.Assign(P);
FImageWidth := P.Width;
FImageHeight := P.Height;
end;
constructor TPBSSRow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
BevelInner := bvNone;
BevelOuter := bvNone;
BevelKind := bkNone;
Color := clWhite;
OnResize := MyPanelResize;
DoubleBuffered := True;
//Left Panel for Image
FPanelLeft := TPanel.Create(Self);
with FPanelLeft do
begin
SetSubComponent(true);
Align := alLeft;
Parent := Self;
//SetBounds(0,0,100,100);
ParentBackground := False;
Color := clBlack;
Font.Color := clLtGray;
Constraints.MinWidth := 300;
BevelInner := bvNone;
BevelOuter := bvNone;
BevelKind := bkNone;
BorderStyle := bsNone;
OnResize := LeftPanelResize;
end;
//Image for left panel
FImage := TImage.Create(Self);
FImage.SetSubComponent(true);
FImage.Align := alClient;
FImage.Parent := FPanelLeft;
FImage.Center := True;
FImage.Stretch := True;
FImage.Proportional := True;
//Right Panel for Info
FPanelRight := TPanel.Create(Self);
with FPanelRight do
begin
SetSubComponent(true);
Parent := Self;
Padding.SetBounds(2,5,5,2);
BevelInner := bvNone;
BevelOuter := bvNone;
BevelKind := bkNone;
BorderStyle := bsNone;
Color := clLtGray;
end;
//Create Memo in Right Panels
FMemo := TMemo.create(self);
with FMemo do
begin
SetSubComponent(true);
Parent := FPanelRight;
Align := alClient;
BevelOuter := bvNone;
BevelInner := bvNone;
BorderStyle := bsNone;
Color := clLtGray;
end;
end;
destructor TPBSSRow.Destroy;
begin
inherited;
end;
end.
A few tips:
TWinControl already ís a container, you do not need another panel inside it to add controls
You do not need an TImage component to view a graphic, that can also with TPaintBox, or as in my example control below, a TCustomControl,
Since all of your other panels are not recognizable (borders and bevels are disabled), loose them altogether and place the TMemo directly on your row control,
SetSubComponent is only for design time usage. You do not need it. Nor the Register procedures for that matter.
Put the global rows array inside your class definition, otherwise multiple TPBSSView controls will use the same array!
TWinControl already tracks all its child controls, so you won't need the array anyway, see my example below,
Make use of the Align property to save you from realigning manually,
If the memo control is just for showing text, then remove it and paint the text yourself.
Try this one for starters:
unit PBSSView;
interface
uses
Windows, Messages, Classes, Controls, SysUtils, Graphics, ExtCtrls, StdCtrls,
Forms, PngImage;
type
TPBSSRow = class(TCustomControl)
private
FGraphic: TPngImage;
FStrings: TStringList;
function ImageHeight: Integer; overload;
function ImageHeight(ControlWidth: Integer): Integer; overload;
function ImageWidth: Integer; overload;
function ImageWidth(ControlWidth: Integer): Integer; overload;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
procedure WMWindowPosChanging(var Message: TWMWindowPosChanging);
message WM_WINDOWPOSCHANGING;
protected
procedure Paint; override;
procedure RequestAlign; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure LoadImageFromStream(Stream: TMemoryStream);
property Strings: TStringList read FStrings;
end;
TPBSSView = class(TScrollBox)
private
function GetRow(Index: Integer): TPBSSRow;
procedure WMEnterSizeMove(var Message: TMessage); message WM_ENTERSIZEMOVE;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
procedure WMExitSizeMove(var Message: TMessage); message WM_EXITSIZEMOVE;
protected
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
procedure AddRow(const FileName: TFileName);
procedure FillRow(Index: Integer; ImageStream: TMemoryStream);
property Rows[Index: Integer]: TPBSSRow read GetRow;
end;
implementation
{ TPBSSRow }
constructor TPBSSRow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 300;
Height := 50;
FStrings := TStringList.Create;
end;
destructor TPBSSRow.Destroy;
begin
FStrings.Free;
FGraphic.Free;
inherited Destroy;
end;
function TPBSSRow.ImageHeight: Integer;
begin
Result := ImageHeight(Width);
end;
function TPBSSRow.ImageHeight(ControlWidth: Integer): Integer;
begin
if (FGraphic <> nil) and not FGraphic.Empty then
Result := Round(ImageWidth(ControlWidth) * FGraphic.Height / FGraphic.Width)
else
Result := Height;
end;
function TPBSSRow.ImageWidth: Integer;
begin
Result := ImageWidth(Width);
end;
function TPBSSRow.ImageWidth(ControlWidth: Integer): Integer;
begin
Result := ControlWidth div 2;
end;
procedure TPBSSRow.LoadImageFromStream(Stream: TMemoryStream);
begin
FGraphic.Free;
FGraphic := TPngImage.Create;
Stream.Position := 0;
FGraphic.LoadFromStream(Stream);
Height := ImageHeight + Padding.Bottom;
end;
procedure TPBSSRow.Paint;
var
R: TRect;
begin
Canvas.StretchDraw(Rect(0, 0, ImageWidth, ImageHeight), FGraphic);
SetRect(R, ImageWidth, 0, Width, ImageHeight);
Canvas.FillRect(R);
Inc(R.Left, 10);
DrawText(Canvas.Handle, FStrings.Text, -1, R, DT_EDITCONTROL or
DT_END_ELLIPSIS or DT_NOFULLWIDTHCHARBREAK or DT_NOPREFIX or DT_WORDBREAK);
Canvas.FillRect(Rect(0, ImageHeight, Width, Height));
end;
procedure TPBSSRow.RequestAlign;
begin
{eat inherited}
end;
procedure TPBSSRow.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TPBSSRow.WMWindowPosChanging(var Message: TWMWindowPosChanging);
begin
inherited;
if (FGraphic <> nil) and not FGraphic.Empty then
Message.WindowPos.cy := ImageHeight(Message.WindowPos.cx) + Padding.Bottom;
end;
{ TPBSSView }
procedure TPBSSView.AddRow(const FileName: TFileName);
var
Row: TPBSSRow;
begin
Row := TPBSSRow.Create(Self);
Row.Align := alTop;
Row.Padding.Bottom := 2;
Row.Parent := Self;
end;
constructor TPBSSView.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
VertScrollBar.Tracking := True;
end;
procedure TPBSSView.FillRow(Index: Integer; ImageStream: TMemoryStream);
begin
Rows[Index].LoadImageFromStream(ImageStream);
end;
function TPBSSView.GetRow(Index: Integer): TPBSSRow;
begin
Result := TPBSSRow(Controls[Index]);
end;
procedure TPBSSView.PaintWindow(DC: HDC);
begin
{eat inherited}
end;
procedure TPBSSView.WMEnterSizeMove(var Message: TMessage);
begin
if not AlignDisabled then
DisableAlign;
inherited;
end;
procedure TPBSSView.WMEraseBkgnd(var Message: TWmEraseBkgnd);
var
DC: HDC;
begin
DC := GetDC(Handle);
try
FillRect(DC, Rect(0, VertScrollBar.Range, Width, Height), Brush.Handle);
finally
ReleaseDC(Handle, DC);
end;
Message.Result := 1;
end;
procedure TPBSSView.WMExitSizeMove(var Message: TMessage);
begin
inherited;
if AlignDisabled then
EnableAlign;
end;
end.
If this still performs badly, then there are multiple other enhancements possible.
Update:
Flickering eliminated by overriding/intercepting WM_ERASEBKGND (and intercepting PaintWindow for versions < XE2),
Better performance by making use of DisableAlign and EnableAlign.
I don't know if this will make a significant difference, but instead setting PBSSRow[I].Width and PBSSRow[I].Top separately, make one call to PBSSRow[I].SetBounds instead. This will save you one Resize event for that SubComponent.

What do I override to manage the layout of components in a Delphi composite component?

I am working on a Delphi component which consists of a panel with some labels and buttons. It can look like this:
or like this:
depending on the setting of a property. Also, the layout of the labels changes depending on the length of the first one.
I have been prototyping this with a TFrame, and doing the layout calculations in the OnPaint method of the frame. What is the right place to do this in a component based on a TPanel? Or, more precisely, in a TCustomAdvPanel, which is what I'm deriving from. Does it work in an override for the Paint method, like so?
procedure TDateRangePicker.Paint;
const
hSpacing = 5;
begin
if FShowRefresh then
begin
btnRefresh.Visible := true;
btnRefresh.Left := Width - hSpacing - btnRefresh.Width;
btnClearDates.Left := btnRefresh.Left - hSpacing - btnClearDates.Width;
btnChooseDates.Left := btnClearDates.Left - hSpacing - btnChooseDates.Width;
end
else begin
btnRefresh.Visible := false;
btnClearDates.Left := Width - hSpacing - btnClearDates.Width;
btnChooseDates.Left := btnClearDates.Left - hSpacing - btnChooseDates.Width;
end;
lblRangeCaption.Left := hSpacing;
lblDateRange.Left := lblRangeCaption.Left + lblRangeCaption.Width + hSpacing;
inherited Paint;
end;
Definitely do not use the Paint method to re-position controls. In the worst case this keeps on triggering the Paint method again, and again... because, well: due to replacing controls, the panel needs to get repainted. Paint, and all equivalents, is only meant for drawing yourself.
On whén to implement your code: this should be done in the setter of the ShowRefresh property.
On how to implement your ShowRefresh property: of course you can move the controls around like you are doing now. You also might consider using Margins (Delphi XE) and aligning the buttons and labels. Then the property setters will become rather simple:
type
TDateRangePicker = class(TCustomPanel)
private
FChooseButton: TButton;
FClearButton: TButton;
FRefreshButton: TButton;
FLabel1: TLabel;
FLabel2: TLabel;
function GetLabel1Caption: String;
function GetRefreshButtonVisible: Boolean;
procedure SetLabel1Caption(const Value: String);
procedure SetRefreshButtonVisible(Value: Boolean);
public
constructor Create(AOwner: TComponent); override;
published
property RefreshButtonVisible: Boolean read GetRefreshButtonVisible
write SetRefreshButtonVisible default True;
property Label1Caption: String read GetLabel1Caption
write SetLabel1Caption;
end;
...
constructor TDateRangePicker.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FChooseButton := TButton.Create(Self);
FChooseButton.Caption := 'Choose';
FChooseButton.Align := alRight;
FChooseButton.AlignWithMargins := True;
FChooseButton.Margins.Left := 10;
FChooseButton.Parent := Self;
FClearButton := TButton.Create(Self);
FClearButton.Caption := 'Clear';
FClearButton.Align := alRight;
FClearButton.AlignWithMargins := True;
FClearButton.Margins.Left := 10;
FClearButton.Parent := Self;
FRefreshButton := TButton.Create(Self);
FRefreshButton.Caption := 'Refresh';
FRefreshButton.Align := alRight;
FRefreshButton.AlignWithMargins := True;
FRefreshButton.Margins.Left := 10;
FRefreshButton.Parent := Self;
FLabel1 := TLabel.Create(Self);
FLabel1.Caption := 'Foo caption: ';
FLabel1.Align := alLeft;
FLabel1.Layout := tlCenter;
FLabel1.Parent := Self;
FLabel2 := TLabel.Create(Self);
FLabel2.Caption := 'From 03/08/2012 to 06/06/2012';
FLabel2.Align := alLeft;
FLabel2.Layout := tlCenter;
FLabel2.Parent := Self;
end;
function TDateRangePicker.GetLabel1Caption: String;
begin
Result := FLabel1.Caption;
end;
function TDateRangePicker.GetRefreshButtonVisible: Boolean;
begin
Result := FRefreshButton.Visible;
end;
procedure TDateRangePicker.SetLabel1Caption(const Value: String);
begin
FLabel1.Caption := Value;
end;
procedure TDateRangePicker.SetRefreshButtonVisible(Value: Boolean);
begin
FRefreshButton.Visible := Value;
FRefreshButton.Left := Width;
end;
And the testing routine:
procedure TMainForm.TestButtonClick(Sender: TObject);
begin
DateRangePicker1.Label1Caption := 'Test: ';
DateRangePicker1.RefreshButtonVisible := not DateRangePicker1.RefreshButtonVisible;
end;
You can create a property for TDateRangePicker like :
property ShowRefresh:boolean read GetShowRefresh write SetShowRefresh
procedure TDateRangePicker.SetShowRefresh( Value : boolean);
begin
btnRefresh.Visible := Value;
// Force autosize after hidding Refresh button
Autosize := True;
end;
So, you have nothing to do during the drawing.
You set the intial positions when you create the child controls, and then update the positions at the time you need to update them (when changing the property, when the Parent component is resized, etc). You MUST NOT changing the positions inside the Paint() method or OnPaint event.
If you are using a modern version of Delphi, you should instead make use of the Align, Margins, and AlignWithMargins properties of the child controls. That way, you just position the controls one time at the time you create them, and let the VCL do all the hard work of repositioning them automatically when it needs to.

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.

Resources