How can I get a similar 'aero effect' in OSX/Windows for delphi xe6 using FMX?
I see this tutorial but is it is for VLC http://theroadtodelphi.wordpress.com/2009/10/26/glass-effect-in-a-delphi-console-application/
I am looking for an effect that is something similar to aero. More specifically, where the effect blurs the background. Similar to a blurred overlay you would see in iOS.
So my form would need to be transparent, and then blur that image where the form is to make use for the background.
Thanks to #RRUZ this is what I have so far. Compiles, but doesn't quite work yet:
unit test;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls
{$IFDEF MACOS32}
,FMX.Platform.Mac,
Macapi.CoreFoundation,
Macapi.CoreGraphics,
Macapi.AppKit,
Macapi.CocoaTypes
{$ENDIF}
;
{$IFDEF MACOS32}
type
CGSConnection = Pointer;
function CGSSetWindowBackgroundBlurRadius(connection: CGSConnection; windowNumber : NSInteger; radius : integer): CGError; cdecl; external libCoreGraphics name _PU + 'CGSSetWindowBackgroundBlurRadius';
function CGSDefaultConnectionForThread : CGSConnection ; cdecl; external libCoreGraphics name _PU + 'CGSDefaultConnectionForThread';
{$ENDIF}
type
TForm1 = class(TForm)
procedure FormShow(Sender: TObject);
private
{ Private declarations }
procedure enableBlurForWindow(Handle : TWindowHandle);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
{ TForm1 }
procedure TForm1.enableBlurForWindow(Handle: TWindowHandle);
var
connection : CGSConnection;
LNSWindow : NSWindow;
begin
LNSWindow:= WindowHandleToPlatform(Handle).Wnd;
LNSWindow.setOpaque(False);
LNSWindow.setBackgroundColor(TNSColor.Wrap(TNSColor.OCClass.colorWithCalibratedWhite(1.0, 0.5)));
connection := CGSDefaultConnectionForThread();
CGSSetWindowBackgroundBlurRadius(connection, LNSWindow.windowNumber, 20);
end;
procedure TForm1.FormShow(Sender: TObject);
begin
enableBlurForWindow(Form1.Handle);
end;
end.
Get this effect in FMX application is much simpler than in VCL, FMX brings specific components to apply effects to other components or forms (including the Blur effect).
Just drop the component on the form and activate it.
Related
I'm a high school student taking programming as one of my subjects, so I'm rather new to Delphi.
I'm writing a game that requires the same (very long) block of code to be run when multiple different events occur. I was wondering if there was a way to write it at the beginning and call it in these different parts of the program, or perhaps get multiple senders to run the same event? The code sets the brush color of 42 different objects to different colors depending on what the user selects (the game is Risk) and when i try using a procedure it get errors for every object telling me it is undeclared.
type
TForm1 = class(TForm)
shpTerr1: TShape;
private
{ Private declarations }
public
procedure CheckOwner;
end;
var
Form1: TForm1;
iArmies, iTemp, i : integer;
iSelected, iSelectedOld : integer;
arrTerrArmies, arrTerrOwners : array[0..41] of integer;
arrPlayerColour : array[0..3] of string;
arrPlayers : array of string;
AttackMode : boolean;
implementation
{$R *.dfm}
procedure CheckOwner;
begin
shpTerr1.Brush.Color := StringToColor('cl' + arrPlayerColour[arrTerrOwners[0]]);
end;
The error is with the TShape.
Any help?
Quick answer:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls;
type
TForm1 = class(TForm)
shpTerr1: TShape;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure CheckOwner;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.CheckOwner;
begin
shpTerr1.Brush.Color:= Color; // I don't know what is arrPlayerColour[arrTerrOwners[0]]
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
CheckOwner;
end;
end.
This application is intended initially for a Windows environment.
While having used only the initial code on the link mentioned below, I had to resorted to replacing the code to accept TabControls/TabItems (FMX) and not using PageControls/TabSheet (VCL) from the link below. With intent to create the Frame with the ability to rebuild content inside of a TabItem (Freeing itself and then using the Construct/Create object approach inside of a procedure).
embarcadero.com (Replacing TabSheets with Frames - by Dan Miser)
Every time I use tiframe1 while having been using Frames since Delphi Seattle 10, I have become accustomed to the ability of using them dynamically. This is one of the approaches. (problem occurs to happen at frame.Free; ) This approach causes the Application to not respond to moving the Window or Exit/Close or anything having to do with the Window layer (including a menu bar).
Does this have anything to do with the fact that TFrames were originally made for VCL?
Project1.dpr
program Project1;
uses
System.StartUpCopy,
FMX.Forms,
Unit1 in 'Unit1.pas' {Form1},
frame1 in 'frame1.pas' {tiframe1: TFrame};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Unit1.pas
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.TreeView,
FMX.Layouts, FMX.Controls.Presentation, FMX.StdCtrls, FMX.TabControl, FMX.Edit;
type
TForm1 = class(TForm)
TabControl1: TTabControl;
TabItem1: TTabItem;
TabItem2: TTabItem;
procedure FormCreate(Sender: TObject);
procedure RefreshFrame();
private
{ Private declarations }
procedure CreateFrame(ATabitem: TTabItem);
function GetFrame(ATabitem: TTabItem): TFrame;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
uses frame1;
type
TFrameClass = class of TFrame;
procedure TForm1.FormCreate(Sender: TObject);
begin
TabItem1.Tag := Integer(Ttiframe1);
CreateFrame(TabItem1);
end;
function TForm1.GetFrame(ATabitem: TTabItem): TFrame;
begin
if not Assigned(ATabitem) then
ATabitem := TabControl1.ActiveTab;
Result := nil;
if Assigned(ATabitem) and (ATabitem.ControlsCount > 0) and (ATabitem.Controls[0] is TFrame) then
Result := TFrame(ATabitem.Controls[0]);
end;
procedure TForm1.CreateFrame(ATabitem: TTabItem);
var
frame: TFrame;
begin
if GetFrame(ATabitem) = nil then
if ATabitem.Tag <> 0 then
begin
frame := TFrameClass(ATabitem.Tag).Create(Self);
frame.Parent := ATabitem;
end;
end;
procedure TForm1.RefreshFrame();
var
frame: TFrame;
begin
if Assigned(FindComponent('tiframe1')) then //
begin
frame := FindComponent('tiframe1') as TFrame;
frame.Free; //This is the cause of all the problems
frame := Ttiframe1.Create(Self);
frame.Parent := TabControl1;
end;
end;
end.
And don't forget to create a Frame and using a Construct/Create as well as at the bottom (before "end.") create an RegisterClass as well.
unit frame1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.TabControl, FMX.Forms, FMX.Layouts, FMX.Dialogs,
FMX.StdCtrls, FMX.Graphics, FMX.Controls.Presentation, FMX.Memo, FMX.Edit;
type
Ttiframe1 = class(TFrame)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
end;
implementation
{$R *.fmx}
uses Unit1;
procedure Ttiframe1.Button1Click(Sender: TObject);
begin
Form1.RefreshFrame();
end;
constructor Ttiframe1.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
initialization
RegisterClass(Ttiframe1);
end.
Now I am also looking to see if TabItems can be re-rendered to display anything new or updated (sort of in a Refresh or Application.ProcessMessages approach), in a similar fashion as a Constructor in a Frame could, effecting such elements as TLabel.Text or perhaps even a TEdit.Text. Inside the construct I have it fetch data from a db dynamically.
The reason for the replacement is that While using (TTreeView) inside of, Frame, inside a TabItem, or otherwise, causes similar occurrence without having a known cause to make the attention/focus away from the MainForm window when I should use the RefreshFrame;
I understand that this is just some made up code to demonstrate the problem, so I will not go into other oddities in the code, but will focus on the problem you describe.
The problem is that the OnClick handler of the button frees the frame and thus the button and the handler returns to a non-existant button.
To avoid this you can do any one of the following
redesign so that the OnClick handler doesn't free the frame (and thus the button)
use a Windows message (since platform is Windows) of your own definition that the button posts to the form and which, when received by the form, calls RefreshFrame
use a 1 ms TTimer that the button enables and which calls RefreshFrame from its OnTimer event where the timer also is disabled
The idea being that the buttons OnClick handler can complete before the frame and button are destroyed.
My delphi(7 or XE5) application is getting wrong monitor resolution when resolution is over 1920x1080.
I have a samsung ultra book with resolution of 2560x1440 running windows 8.1
When I run the simple resolution test, the app returns right at 1920x1080 and less, but when run the app with max resolution of 2560x1440 the resolution returned is 1600x900.
This is the code, I try with dpiaware manifest and get same wrong result, any idea about this ?
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function GetDesktopArea: TRect;
var
m: integer;
USCR: TScreen;
begin
USCR := TScreen.Create(Application);
try
with USCR do
if MonitorCount = 1 then
Result := WorkAreaRect
else
begin
for m:=0 to MonitorCount-1 do
begin
with Monitors[m] do
if Primary then
Result := Rect(Left, Top, Left+Width, Top+Height);
// UpdScreen.Monitors[m].BoundsRect;
end;
end;
finally
USCR.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
msg : String;
scr : TRect;
begin
scr := GetDesktopArea;
msg := Format('Left:%d Top:%d -- W:%d H:%d', [scr.Left, scr.Top, scr.Width, scr.Height] );
Memo1.Lines.Add( msg );
end;
end.
Thanks
The likely explanation is that your application is not dpi aware and so experiences dpi virtualization. I know of nothing else that could influence these system API calls.
You state that you have manifested the application to be dpi aware. Since the evidence is that your app is not dpi aware then I conclude that you have applied the manifest incorrectly.
Don't ever instantiate TScreen. Use the Screen global variable instead.
I used the trick described in this question to display a FireMonkey form on a TPanel in a VCL application. My problem is that clicking (controls on) the embedded form causes the VCL form (containing that TPanel) to become deactivated. The most obvious consequence of that is the window border changing color all the time.
When displaying a VCL form on a TPanel of another, this doesn't happen; the forms apparently "merge". What should I do to reach a similar result with FireMonkey? I want controls on the FireMonkey form to be usable, but keep the parent form activated.
Update 1
VCL
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, FMX.Forms, Vcl.Forms,
Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, FMX.Platform.Win;
type
TMainForm = class(TForm)
Panel1: TPanel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.dfm}
uses FireMonkeyForms;
procedure TMainForm.Button1Click(Sender: TObject);
var
LFMForm: FireMonkeyForms.TForm1;
LFMHWnd: HWND;
begin
LFMForm := FireMonkeyForms.TForm1.Create(nil);
LFMForm.Left := 0;
LFMForm.Top := 0;
LFMForm.Height := Panel1.ClientHeight;
LFMForm.Width := Panel1.ClientWidth;
LFMForm.BorderStyle := TFmxFormBorderStyle.bsNone;
LFMForm.BorderIcons := [];
LFMHWnd := FmxHandleToHWND(LFMForm.Handle);
SetWindowLong(LFMHWnd, GWL_STYLE, GetWindowLong(LFMHwnd, GWL_STYLE) or WS_CHILD);
Winapi.Windows.SetParent(LFMHWnd, Panel1.Handle);
LFMForm.Visible := True;
end;
end.
FireMonkey
unit FireMonkeyForms;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Layouts, FMX.Memo;
type
TForm1 = class(TForm)
Label1: TLabel;
Memo1: TMemo;
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
end.
The cause of the behavior is that the window manager does not know you have made your firemonkey window a child, hence it is deactivating the previously active window when you activate the firemonkey window. As is documented in SetParent function you have to set the child flag manually. An example usage could be:
var
FMForm: TFMForm1;
FMHWnd: HWND;
begin
FMForm := TFMForm1.Create(nil);
FMForm.Left := 0;
FMForm.Top := 0;
FMHWnd := FmxHandleToHWND(FMForm.Handle);
SetWindowLong(FMHWnd, GWL_STYLE, GetWindowLong(FMHwnd, GWL_STYLE) or WS_CHILD);
winapi.windows.SetParent(FMHWnd, Panel1.Handle);
FMForm.Visible := True;
Update:
If you have to remove the fmx form's borders, setting BorderStyle sets the WS_POPUP style which you cannot use with WS_CHILD. In that case set the styles you need explicitly instead of getting and 'or'ring them. F.i.
..
LFMForm.BorderIcons := [];
LFMForm.BorderStyle := TFmxFormBorderStyle.bsNone;
LFMHWnd := FmxHandleToHWND(LFMForm.Handle);
SetWindowLong(LFMHWnd, GWL_STYLE, WS_CHILDWINDOW or WS_BORDER);
..
I'm using the following code to make a form transparent, but when the application has a VCL style enabled the form is paint with the background color of the VCL style instead of be transparent.
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs;
type
TForm1 = class(TForm)
procedure FormShow(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure CreateParams(var Params:TCreateParams); override;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := WS_EX_TRANSPARENT or WS_EX_TOPMOST;
//Params.ExStyle := Params.ExStyle or WS_EX_LAYERED;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Brush.Style:=bsClear;
BorderStyle:=bsNone;
//SetLayeredWindowAttributes(Handle, 0, 230, $00000002);
end;
FYI The code works fine if the the vcl style is set to Windows.
Exist another way to make a form transparent to workaround this issue?
It seems like a bug to me. The VCL Styles use Style hooks to intercept the paint methods and the Windows messages related to these operations, So in this case you must focus your atention in the PaintBackground method of the TFormStyleHook class located in the Vcl.Forms, from here you create a new style hook class (which descends from TFormStyleHook), override the PaintBackground method, fix the code and finally before to use it call the RegisterStyleHook method to register the New style hook. check this article Fixing a VCL Style bug in the TPageControl and TTabControl components to see an example.
UPDATE
Check this sample
unit Unit138;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs;
type
TForm138 = class(TForm)
procedure FormCreate(Sender: TObject);
private
procedure CreateParams(var Params:TCreateParams); override;
public
end;
var
Form138: TForm138;
implementation
Uses
Vcl.Themes,
Vcl.Styles,
uPatch;
{$R *.dfm}
procedure TForm138.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := WS_EX_TRANSPARENT or WS_EX_TOPMOST;
end;
procedure TForm138.FormCreate(Sender: TObject);
begin
Brush.Style:=bsClear;
BorderStyle:=bsNone;
end;
initialization
TStyleManager.Engine.UnRegisterStyleHook(TForm, TFormStyleHook);//unregister the original style hook
TStyleManager.Engine.RegisterStyleHook(TForm, TMyStyleHookClass); //register the new style hook
end.
The New Style Hook Class
unit uPatch;
interface
uses
Vcl.Graphics,
Vcl.Forms;
type
TMyStyleHookClass= class(TFormStyleHook)
protected
procedure PaintBackground(Canvas: TCanvas); override;
end;
implementation
uses
Winapi.Windows,
System.Types,
Vcl.Themes;
procedure TMyStyleHookClass.PaintBackground(Canvas: TCanvas);
{This is only a basic sample for fix a specific scenario}
var
Details: TThemedElementDetails;
R: TRect;
begin
if StyleServices.Available then
begin
if (GetWindowLong(Form.Handle,GWL_EXSTYLE) AND WS_EX_TRANSPARENT) = WS_EX_TRANSPARENT then
if Form.Brush.Style = bsClear then Exit;
Details.Element := teWindow;
Details.Part := 0;
R := Rect(0, 0, Control.ClientWidth, Control.ClientHeight);
StyleServices.DrawElement(Canvas.Handle, Details, R);
end;
end;
end.
On a separate note, have you tried using the TransparentColor and TranparentColorValue properties instead of manipulating the window styles in CreateParams()?
I use OverridePaintNC := False to prevent draw Styles on NC area. And there is OverrideEraseBkgnd too. Maybe this help.