I'm using Delphi 7. I've written some code to create buttons at runtime (I need lots of the exact same buttons in the exact same locations on every form, which is why I've decided to do that). But I'm having trouble referencing them in procedures (OnClick, to be precise). I want another form to open when a button is clicked.
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, jpeg, ExtCtrls;
procedure buttons(a: TForm);
type
TForm2 = class(TForm)
Image1: TImage;
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2; Button1, Button2, Button3, Button4: TButton;
implementation
uses Unit3, Unit4;
{$R *.dfm}
procedure buttons(a: TForm);
begin
Button1 := TButton.Create(a);
Button1.Name := 'Button1';
Button1.Left := 712;
Button1.Top := 96;
Button1.Width := 81;
Button1.Height := 41;
Button1.Visible := True;
Button1.Parent := a;
Button1.Enabled := False;
Button1.Caption := 'Go forwards';
Button2 := TButton.Create(a);
Button2.Name := 'Button2';
Button2.Left := 800;
Button2.Top := 152;
Button2.Width := 81;
Button2.Height := 41;
Button2.Visible := True;
Button2.Parent := a;
Button2.Enabled := False;
Button2.Caption := 'Go right';
Button3 := TButton.Create(a);
Button3.Name := 'Button3';
Button3.Left := 624;
Button3.Top := 152;
Button3.Width := 81;
Button3.Height := 41;
Button3.Visible := True;
Button3.Parent := a;
Button3.Enabled := False;
Button3.Caption := 'Go left';
Button4 := TButton.Create(a);
Button4.Name := 'Button4';
Button4.Left := 712;
Button4.Top := 208;
Button4.Width := 81;
Button4.Height := 41;
Button4.Visible := True;
Button4.Parent := a;
Button4.Enabled := False;
Button4.Caption := 'Go back';
end;
procedure TForm2.FormShow(Sender: TObject);
begin
buttons(Form2);
Button1.Enabled := True;
Button2.Enabled := True;
end;
procedure TForm2.Button1Click(Sender: TObject);
begin
Form3.Show;
Form2.Hide;
end;
procedure TForm2.Button2Click(Sender: TObject);
begin
Form4.Show;
Form2.Hide;
end;
end.
I've declared the OnClicks in 'type', as well, as I probably should. The program runs, but the created buttons don't work, though are clickable. Ideas?
P.S.: I know I could've written more compact code to create all those buttons, but I didn't have time to think about it, and it is pretty much beside the point. I know it might be hard to read - all you need to know is, I set the same kinds of properties on every button - you need only look at Button1, the others are identical.
P.P.S.: NOT a dup question to this: Delphi - Referencing Components created at Runtime. I couldn't find a solution to my problem in that one.
First of all you should clean up your code a bit. But it's not why your code isn't working. It's because you forgot to assign an OnClick Event to your button:
Have a look at this :
unit Unit19;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm19 = class(TForm)
procedure FormCreate(Sender: TObject);
private
Button1: TButton;
Button2: TButton;
Procedure CreateButtons;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
public
{ Public declarations }
end;
var
Form19: TForm19;
implementation
{$R *.dfm}
procedure TForm19.Button1Click(Sender: TObject);
begin
Caption := 'Button1 Clicked';
end;
procedure TForm19.Button2Click(Sender: TObject);
begin
Caption := 'Button2 Clicked';
end;
procedure TForm19.CreateButtons;
begin
Button1 := TButton.Create(Self);
Button1.Name := 'Button1';
Button1.Left := 712;
Button1.Top := 96;
Button1.Width := 81;
Button1.Height := 41;
Button1.Visible := True;
Button1.Parent := Self;
Button1.Enabled := False;
Button1.OnClick := Button1Click;
Button1.Caption := 'Go forwards';
Button2 := TButton.Create(Self);
Button2.Name := 'Button2';
Button2.Left := 800;
Button2.Top := 152;
Button2.Width := 81;
Button2.Height := 41;
Button2.Visible := True;
Button2.Parent := Self;
Button2.Enabled := False;
Button2.Caption := 'Go right';
Button2.OnClick := Button2Click;
end;
procedure TForm19.FormCreate(Sender: TObject);
begin
CreateButtons;
end;
end.
First the cleanup: I've moved the declaration of your button up to the private part of the form that owns them.
About the owner of the button, the parameter of the constructor; It must be the form. Because when you destroy the form it will also destroy your buttons, and no memory will be leaked.
Then the missing OnClick event that is solved with this line:
Button1.OnClick := Button1Click;
I simply tell the button which procedure to be called when the user click the button.
I hope this answers you question.
In your situation I would use Frames. You can place all buttons on this frame, you can change the behavior by using properties, assign all needed events and put it on your form at design time or at run time
Related
I Have a Windows Media Player ActiveX control. I want it to be aligned to its parent TPanel.
The problem is that no matter what I try the WMP control is always set to its initial size without the possibility to resize it.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, XpMan, ExtCtrls, WMPLib_TLB;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
public
Panel: TPanel;
MP: TWindowsMediaPlayer;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Width := 450;
Height := 260;
Panel := TPanel.Create(Self);
Panel.Parent := Self;
Panel.Align := alClient;
MP := TWindowsMediaPlayer.Create(Self);
// MP.stretchToFit := True;
MP.Parent := Panel;
MP.Align := alClient;
MP.URL := 'https://www.w3schools.com/html/mov_bbb.mp4';
end;
When you open the form the WMP control looks fine:
But when you resize the form, the WMP control wont align to the parent Panel:
This is actually the effect I see when trying to enlarge:
What can I do to make the WMP control behave as expected?
I have tried many stupid things like:
procedure TForm1.FormResize(Sender: TObject);
begin
if not Assigned(MP) then Exit;
MP.Width := Panel.ClientWidth;
MP.Height := Panel.ClientHeight;
Panel.Realign;
end;
But nothing works!
This is a bug in Delphi 7 TOleControl.SetBounds in OleCtrls. it was fixed in newer versions.
procedure TOleControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
LRect: TRect;
begin
if ((AWidth <> Width) and (Width > 0)) or ((AHeight <> Height) and (Height > 0)) then
begin
if (FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0) or
((FOleObject.SetExtent(DVASPECT_CONTENT, Point(
MulDiv(AWidth, 2540, Screen.PixelsPerInch),
MulDiv(AHeight, 2540, Screen.PixelsPerInch))) <> S_OK)) then
begin
AWidth := Width;
AHeight := Height;
end;
{ fix start }
if FOleInplaceObject <> nil then
begin
LRect := Rect(Left, Top, AWidth, AHeight);
FOleInplaceObject.SetObjectRects(LRect, LRect);
end;
{ fix end }
end;
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;
After applying that to a local copy of OleCtrls everything works fine.
I'm intercepting and suppressing the WM_PASTE message for a TDBEdit by assigning its WindowProc property, as described in this answer.
After pressing Ctrl+V, despite the WM_PASTE is intercepted, the dataset's state changes from dsBrowse to dsEdit.
Why is this happening and how could I avoid that?
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, DBCtrls, StdCtrls, Mask, DB, DBClient;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
FPrevWindowProc : TWndMethod;
procedure MyWindowProc(var AMessage: TMessage);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var
Dst : TClientDataSet;
Dsc : TDataSource;
Fld : TField;
Nav : TDBNavigator;
Edt : TDBEdit;
begin
//dataset
Dst := TClientDataSet.Create(Self);
Dst.FieldDefs.Add('TEST', ftString, 20);
Dst.CreateDataSet();
Dst.Active := True;
Fld := Dst.Fields[0];
Dst.Append();
Fld.AsString := 'test';
Dst.Post();
//datasource
Dsc := TDataSource.Create(Self);
Dsc.DataSet := Dst;
//navigator
Nav := TDBNavigator.Create(Self);
Nav.DataSource := Dsc;
Nav.Top := 3;
Nav.Left := 3;
Nav.Parent := Self;
//editor
Edt := TDBEdit.Create(Self);
Edt.DataSource := Dsc;
Edt.DataField := Fld.FieldName;
Edt.Top := 31;
Edt.Left := 3;
Edt.Parent := Self;
FPrevWindowProc := Edt.WindowProc;
Edt.WindowProc := MyWindowProc;
end;
procedure TForm1.MyWindowProc(var AMessage: TMessage);
begin
if(AMessage.Msg = WM_PASTE) then
begin
ShowMessage('WM_PASTE, exit!');
Exit;
end;
FPrevWindowProc(AMessage);
end;
end.
Using the interposer class solution in Remy's answer to your linked question, if you create a BeforeEdit handler for your DataSet and put a breakpoint in it, you will find that the breakpoint trips before the interposer's WMPaste() method is entered.
If you then trace out of the BeforeEdit handler, you will eventually arrive in TDBEdit.KeyPress() which (in D7) contains the code below:
procedure TDBEdit.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
not FDataLink.Field.IsValidChar(Key) then
begin
MessageBeep(0);
Key := #0;
end;
case Key of
^H, ^V, ^X, #32..#255:
FDataLink.Edit;
#27:
begin
FDataLink.Reset;
SelectAll;
Key := #0;
end;
end;
end;
So, the DataSet is put into dsEdit state by the call to FDataLink.Edit() as a result of KeyPress() seeing the ^V character.
You could achieve the behavior you want by also overriding KeyPress() in the interposer class. The following will prevent pressing ^V from having any effect:
type // This can be in your Form's unit but must go before your Form's type declaration
TDBEdit = class(DBCtrls.TDBEdit)
procedure WMPaste(var Message: TMessage); message WM_PASTE;
procedure KeyPress(var Key: Char); override;
end;
[...]
procedure TDBEdit.WMPaste(var Message: TMessage);
begin
if not (Message.Msg = WM_PASTE) then
inherited;
end;
procedure TDBEdit.KeyPress(var Key: Char);
begin
case Key of
^V : Key := #0;
end; { case }
inherited;
end;
[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;
I like to place a feedback button on may main (MDIParent) form that simulates those in webpages.
Like it to grow when the mouse goes over it. Just like the web.
The form with questions and the send of the data, I really don't need it, just the visual stuff.
Is there any such component ?.
I don't think it's difficult to do, but if it already exist it will same me some time.
Thanks
To make an animated slide panel you can use a code like follows:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
FFeedbackBtn: TPanel;
FFeedbackPanel: TPanel;
procedure OnFeedbackBtnMouseEnter(Sender: TObject);
procedure OnFeedbackPanelMouseLeave(Sender: TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FFeedbackBtn := TPanel.Create(Self);
FFeedbackBtn.Parent := Self;
FFeedbackBtn.Anchors := [akLeft, akTop, akBottom];
FFeedbackBtn.Caption := '';
FFeedbackBtn.SetBounds(0, 0, 40, ClientHeight);
FFeedbackBtn.OnMouseEnter := OnFeedbackBtnMouseEnter;
FFeedbackPanel := TPanel.Create(Self);
FFeedbackPanel.Parent := Self;
FFeedbackPanel.Anchors := [akLeft, akTop, akBottom];
FFeedbackPanel.Caption := 'Feedback panel';
FFeedbackPanel.Visible := False;
FFeedbackPanel.SetBounds(0, 0, 250, ClientHeight);
FFeedbackPanel.OnMouseLeave := OnFeedbackPanelMouseLeave;
end;
procedure TForm1.OnFeedbackBtnMouseEnter(Sender: TObject);
begin
AnimateWindow(FFeedbackPanel.Handle, 150, AW_ACTIVATE or AW_SLIDE or
AW_HOR_POSITIVE);
end;
procedure TForm1.OnFeedbackPanelMouseLeave(Sender: TObject);
begin
AnimateWindow(FFeedbackPanel.Handle, 150, AW_HIDE or AW_SLIDE or
AW_HOR_NEGATIVE);
end;
end.
Update:
Here's another version of the above, now with a vertical text like a typical feedback button has, rendered on a paint box stretched on the button panel:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
FFeedbackBtn: TPanel;
FFeedbackBtnOverlay: TPaintBox;
FFeedbackPanel: TPanel;
procedure OnFeedbackBtnMouseEnter(Sender: TObject);
procedure OnFeedbackPanelMouseLeave(Sender: TObject);
procedure OnFeedbackBtnOverlayPaint(Sender: TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FFeedbackBtn := TPanel.Create(Self);
FFeedbackBtn.Parent := Self;
FFeedbackBtn.Anchors := [akLeft, akTop, akBottom];
FFeedbackBtn.Caption := '';
FFeedbackBtn.Color := $0000B3FF;
FFeedbackBtn.ParentBackground := False;
FFeedbackBtn.SetBounds(0, 0, 40, ClientHeight);
FFeedbackBtnOverlay := TPaintBox.Create(Self);
FFeedbackBtnOverlay.Parent := FFeedbackBtn;
FFeedbackBtnOverlay.Align := alClient;
FFeedbackBtnOverlay.OnPaint := OnFeedbackBtnOverlayPaint;
FFeedbackBtnOverlay.OnMouseEnter := OnFeedbackBtnMouseEnter;
FFeedbackPanel := TPanel.Create(Self);
FFeedbackPanel.Parent := Self;
FFeedbackPanel.Anchors := [akLeft, akTop, akBottom];
FFeedbackPanel.Caption := 'Feedback panel';
FFeedbackPanel.Color := $0000F9FF;
FFeedbackPanel.ParentBackground := False;
FFeedbackPanel.Visible := False;
FFeedbackPanel.SetBounds(0, 0, 250, ClientHeight);
FFeedbackPanel.OnMouseLeave := OnFeedbackPanelMouseLeave;
end;
procedure TForm1.OnFeedbackBtnMouseEnter(Sender: TObject);
begin
AnimateWindow(FFeedbackPanel.Handle, 150, AW_ACTIVATE or AW_SLIDE or
AW_HOR_POSITIVE);
end;
procedure TForm1.OnFeedbackPanelMouseLeave(Sender: TObject);
begin
AnimateWindow(FFeedbackPanel.Handle, 150, AW_HIDE or AW_SLIDE or
AW_HOR_NEGATIVE);
end;
procedure TForm1.OnFeedbackBtnOverlayPaint(Sender: TObject);
var
S: string;
X, Y: Integer;
begin
S := 'Feedback...';
with FFeedbackBtnOverlay do
begin
Canvas.Brush.Color := $0000B3FF;
Canvas.FillRect(ClientRect);
Canvas.Font.Orientation := 900;
X := (ClientWidth - Canvas.TextHeight(S)) div 2;
Y := ClientHeight - (ClientHeight - Canvas.TextWidth(S)) div 2;
Canvas.TextOut(X, Y, S);
end;
end;
end.
And the result:
You should also implement some logic to prevent user to hide the feedback panel when will actually filling the fields, but it's a natural weakness of such kind of a feedback form.
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.