I've recently started converting an application to FireMonkey, and started with the simple controls. For some reason, their position is off, compared to dropped components on the form like say TPanel or TButton. From my tests, it appears the position is doubled.
My test project is simple: (in Delphi XE5)
create a new firemonkey HD application
drop a panel on the form at position (100,100) right click on it and "send to back"
paste the following code (adapt names where needed) for the custom component
code:
type
TTest = class(TPaintBox)
private
FBitmap: TBitmap;
public
Constructor Create(AOwner:TComponent); override;
Destructor Destroy; override;
procedure Paint; override;
end;
{ TTest }
constructor TTest.Create(AOwner: TComponent);
begin
inherited;
FBitmap := TBitmap.Create;
FBitmap.LoadFromFile('c:\test.png');
Width := FBitmap.Width;
Height := FBitmap.Height;
end;
destructor TTest.Destroy;
begin
FreeAndNil(FBitmap);
inherited;
end;
procedure TTest.Paint;
begin
Canvas.DrawBitmap(FBitmap,
TRectf.Create(0, 0, FBitmap.Width, FBitmap.Height),
AbsoluteRect,
1);
end;
paste the following code to dynamically create the above component
code:
procedure TForm2.FormCreate(Sender: TObject);
var t: TTest;
begin
t := TTest.Create(self);
t.Parent := self;
t.Position.X := 50;
t.Position.Y := 50;
end;
Build it for Win32.
On my end, the image appears in the upper left corner for the panel, which is at 100,100 but the control is clearly set to position itself at 50,50
Debugging shows correct values on positions and rects.
I can't figure out what is going on. Maybe somebody has some suggestions/explanations.
Thanks.
AbsoluteRect ist the rectangle of the Control relative to it's Form. If you want to paint something you have to use local coordinates, in this case LocalRect.
Canvas.DrawBitmap(FBitmap, TRectf.Create(0, 0, FBitmap.Width, FBitmap.Height), LocalRect, 1);
Related
I am trying to define an area in the shape of a triangle and check if the mouse is in it. I can find if the mouse is in a certain square area using the code below. My program needs to detect the mouse in a triangle or a more complex shape.
if (Mouse.CursorPos.X < 20) or (50 > tbmn.Left + tbmn.Width) or (Mouse.CursorPos.Y < 20) or (Mouse.CursorPos.Y > tbmn.Top + 60) then
begin
end;
So basically, what I want to do is have a shape anywhere on the screen and check if the mouse is in it.
Is there a way to easily calculate a region of the screen and detect if the mouse is present in it?
Asuming you have a component where you draw a triangle inside and only want to have the component detect mouse hit when the cursor is over the visible part of the shape then you could do something like this:
Have an alpha layer on the component being drawn. Then intercept the Windows CM_HITTEST message. in the hit test message procedure you then check if the alpha value is 0. If it is 0 then the mouse is over an area with some visible color value.
Type
TSomeComponent = class(TGraphicControl)
private
FPNG : TGraphic;
procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; Override;
end;
procedure Register;
implementation
uses
GR32, GR32_Brushes,Winapi.Windows;
procedure TSomeComponent.CMHitTest(var Message: TCMHitTest);
var
colorEntry: TColor32Entry;
bmp : TBitmap32;
begin
bmp := TBitmap32.Create();
try
try
bmp.Assign(FPNG);
colorEntry := TColor32Entry(bmp.Pixels[Message.XPos,Message.YPos]);
if colorEntry.A <> 0 then
Message.Result := HTCLIENT
else
Message.Result := HTNOWHERE;
except
Message.Result := HTCLIENT;
end;
finally
bmp.Free;
end;
end;
You can use region functions from WinApi.
Here are example for simple triangle:
function PtInTriangle(ptX,ptY,X1,Y1,X2,Y2,X3,Y3:integer):Boolean;
var rgn:THandle; pts:array [0..2] of TPoint;
begin
pts[0].X:=X1; pts[0].Y:=Y1;
pts[1].X:=X2; pts[1].Y:=Y2;
pts[2].X:=X3; pts[2].Y:=Y3;
rgn := CreatePolygonRgn( pts[0], 3, WINDING);
Result := PtInRegion(rgn, ptX, ptY);
DeleteObject(rgn);
end;
This function takes about ~30..40us on my machine, and PtInRegion() takes only ~10% of this time (so, you can optimize it by caching Region object). Here are code with simple bencmark:
function PtInTriangle(ptX,ptY,X1,Y1,X2,Y2,X3,Y3:integer):Boolean;
var rgn:THandle; pts:array [0..2] of TPoint;
t,t1,t2,t3:Int64;
begin
// Create region
QueryPerformanceCounter(t);
pts[0].X:=X1; pts[0].Y:=Y1;
pts[1].X:=X2; pts[1].Y:=Y2;
pts[2].X:=X3; pts[2].Y:=Y3;
rgn := CreatePolygonRgn( pts[0], 3, WINDING);
QueryPerformanceCounter(t1); Dec(t1,t);
// Check point
QueryPerformanceCounter(t);
Result := PtInRegion(rgn, ptX, ptY);
QueryPerformanceCounter(t2); Dec(t2,t);
// Delete region
QueryPerformanceCounter(t);
DeleteObject(rgn);
QueryPerformanceCounter(t3); Dec(t3,t);
// Debug output
QueryPerformanceFrequency(t);
OutputDebugString(PChar(Format('All:%d(%.1fus) Create:%d PtInRect:%d(%.1f%%) Delete:%d',
[t1+t2+t3,(t1+t2+t3)/t*1E6,t1,t2,t2*100/(t1+t2+t3),t3])));
end;
Also, you can create complex regions with CreatePolyPolygonRgn() or CombineRgn().
Need a component derived from TMemo (not TSyn components)
I need a line to the left(inside or outside) of a TMemo whose thickness(optional) and color can be controlled just for the purposes of indication. It need not be functional as a gutter but looks like one especially like that of a SynMemo as shown in the image. The problem with SynMemo is that it doesn't support variable width fonts like Tahoma but the TMemo does.
I tried making a few composite components with CustomContainersPack by combining a TShape with TMemo, even superimposing a TMemo on top of TSynMemo but didn't succeed as the paint while dragging made it look disassembled and CCPack is not that robust for my IDE.
KMemo, JvMemo and many other Torry.net components were installed and checked for any hidden support for achieving the same but none worked.
Grouping of components together is also not a solution for me since many mouse events are tied to the Memo and calls to FindVCLWindow will return changing components under the mouse. Furthermore many components will be required so grouping with TPanel will up the memory usage.
You can use the WM_Paint message and a hack to do this without creating a new component,
Otherwise create a descendant of TMemo and apply the same changes below
TMemo = class(Vcl.StdCtrls.TMemo)
private
FSidecolor: TColor;
FSideColorWidth: Integer;
FAskForAttention: Boolean;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure SetSideColorWidth(const Value: Integer);
procedure SetSideColor(const Value: TColor);
procedure SetAskForAttention(const Value: Boolean);
published
property SideColor: TColor read FSideColor write SetSideColor default clRed;
property SideColorWidth: Integer read FSideColorWidth write SetSideColorWidth default 2;
property AskForAttension: Boolean read FAskForAttention write SetAskForAttention;
end;
{ TMemo }
procedure TMemo.SetAskForAttention(const Value: Boolean);
begin
FAskForAttention := Value;
Invalidate;
end;
procedure TMemo.SetSideColor(const Value: TColor);
begin
FSideColor := Value;
Invalidate;
end;
procedure TMemo.SetSideColorWidth(const Value: Integer);
begin
FSideColorWidth := Value;
Invalidate;
end;
procedure TMemo.WMPaint(var Message: TWMPaint);
var
DC: HDC;
Pen: HPen;
R,G,B: Byte;
begin
inherited;
if FAskForAttention then
begin
DC := GetWindowDC(Handle);
try
B := Byte(FSidecolor);
G := Byte(FSidecolor shr 8);
R := Byte(FSidecolor shr 16);
Pen := CreatePen(PS_SOLID, FSideColorWidth, RGB(R,G,B));
SelectObject(DC, Pen);
SetBkColor(DC, RGB(R,G,B));
Rectangle(DC, 1, 1, FSideColorWidth, Height - 1);
DeleteObject(Pen);
finally
ReleaseDC(Handle, DC);
end;
end;
end;
And you can use it like this
procedure TForm15.Button1Click(Sender: TObject);
begin
memo1.SideColor := ColorBox1.Selected;
memo1.SideColorWidth := 2;
memo1.AskForAttension := True;
end;
and you get this result
Limitations:
As this is merely another hack to draw a simple rectangle on the side, do not expect it to be perfect on all situations. I did notice the following when testing:
If the border is too thick you get the following effect
When on mouse move the line sometimes disappear and don't get painted (I think it is because of drawing focus rect).
Note: I see the guys in comments suggested to create a custom component with panel and memo put together, If you want to try this, take a look at my answer to
Creating a new components by combining two controls (TEdit and TTrackBar) in Delphi VCL
It is basically the same Ideas.
Edit:
Ok I took into consideration what is mentioned in comments and adapted my answer,
I also changed the way I'm getting the canvas of the component. The new implementation becomes this
{ TMemo }
procedure TMemo.SetAskForAttention(const Value: Boolean);
var
FormatRect: TRect;
begin
if FAskForAttention <> Value then
begin
FAskForAttention := Value;
if not FAskForAttention then
begin
Perform(EM_SETRECT, 0, nil);
end
else
begin
FormatRect := GetClientRect;
if IsRightToLeft then
FormatRect.Right := FormatRect.Right - FSideColorWidth - 3
else
FormatRect.Left := FormatRect.Left + FSideColorWidth + 3;
Perform(EM_SETRECT, 0, FormatRect);
end;
Invalidate;
end;
end;
procedure TMemo.SetSideColor(const Value: TColor);
begin
if FSideColor <> Value then
begin
FSideColor := Value;
Invalidate;
end;
end;
procedure TMemo.SetSideColorWidth(const Value: Integer);
var
FormatRect: TRect;
begin
if FSideColorWidth <> Value then
begin
FSideColorWidth := Value;
FormatRect := GetClientRect;
if IsRightToLeft then
FormatRect.Right := FormatRect.Right - FSideColorWidth - 3
else
FormatRect.Left := FormatRect.Left + FSideColorWidth + 3;
Perform(EM_SETRECT, 0, FormatRect);
end;
end;
procedure TMemo.WMPaint(var Message: TWMPaint);
var
Canvas: TControlCanvas;
CRect: TRect;
begin
inherited;
if FAskForAttention then
begin
Canvas := TControlCanvas.Create;
try
Canvas.Control := Self;
Canvas.Font.Assign(Self.Font);
CRect := GetClientRect;
if IsRightToLeft then
CRect.Left := CRect.Right - FSideColorWidth
else
CRect.Width := FSideColorWidth;
Canvas.Brush.Color := FSidecolor;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(CRect);
finally
Canvas.Free;
end;
end;
end;
There is no limitations for the size and it does not overlap the scrollbars.
Final result:
References I used to write this answer:
MSDN Painting and Drawing Functions
MSDN Using the WM_PAINT Message
Creating Colored Pens and Brushes example
Vcl.Controls TWinControl WM_Paint message implementation
EM_SETRECT message
How can I get a TEdit's canvas in Delphi? (Kobik's answer)
Instead of writing a custom control, put a panel or a shape beside the standard memo and give it any colour you like.
If this is too tedious to repeat many times, then put the memo and the shape on a frame and put that in the repository. Set the anchors to make sure they resize correctly. You don't even need to write code for that and you have an instant "imitation custom control".
Much better and simpler than writing, installing and testing a custom control, IMO.
Now if you want to put text or numbers or icons in the gutter, then it would pay out to write a custom control. Use EM_SETRECT to set the internal formatting rectangle, and custom draw the gutter in the overridden Paint method. Do not forget to call inherited.
I'm very new to delphi programming:(
I'm trying to make a customized component with a transparent background layer and a top layer with circle shape. However, the below code works fine when added on to a form.
Exception the fact that is there is another component overlaps with or on top of the the customized component, it lies below and doesn't show.
I've tried below on a form
BadgeTest1.BringToFront;
BadgeTest1.ComponentIndex:=2;
IndexVal:= BadgeTest1.ComponentIndex;
However, still doens't work. Is there anyway for the customized component to show on top of the other components? only the circle shape part?
Also, I've been trying to place a caption in the center(horizontally and vertically) of the customized component, I've tried with TextOut() procedure. if there is a better option, could you please let me know?
below is my code for the customized component called BadgeTest.
Please, help,
Thank you so much!
type
TBadgeTest=class(TGraphicControl)
private
FCaption:TCaption;
FColor:TColor;
FLayers:TLayerCollection;
FHeight:Integer;
FWidth:Integer;
protected
procedure Paint; override;
procedure SetBkgLayer;
procedure SetSecondLayer;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Caption:TCaption read FCaption write FCaption;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Sample', [TBadgeTest]);
end;
constructor TBadgeTest.Create(AOwner: TComponent);
var
ACanvas:TcxCanvas;
begin
inherited;
FHeight:=20;
Self.Height:=FHeight;
Constraints.MaxHeight:=20;
Constraints.MinHeight:=20;
FHeight:=20;
Self.Width:=FWidth;
Constraints.MaxWidth:=20;
Constraints.MinWidth:=20;
end;
destructor TBadgeTest.Destroy;
begin
inherited;
end;
procedure TBadgeTest.SetBkgLayer;
var
Bitmap:TBitmap32;
Layer: TCustomLayer;
begin
FLayers := TLayerCollection.Create(Self);
Layer := FLayers.Add(TBitmapLayer);
Layer.Index:=0;
Bitmap:= TBitmap32.Create;
Bitmap.DrawMode:=dmOpaque;
Bitmap.SetSize(Width, Height);
Bitmap.clear($00000000);
Bitmap.Canvas.Pen.Width:=0;
Bitmap.Canvas.Brush.Color:=$00107EFF;
Bitmap.Canvas.Brush.Style:=bsClear;
Bitmap.Canvas.Ellipse(Rect(0,0,20,20));
end;
procedure TBadgeTest.SetSecondLayer;
var
Bitmap:TBitmap32;
Layer: TCustomLayer;
begin
Layer := FLayers.Add(TBitmapLayer);
Layer.Index:=1;
Layer.LayerOptions:= LOB_VISIBLE;
Bitmap:=TBitmap32.Create;
Bitmap.DrawMode:=dmCustom;
Bitmap.SetSize(Width, Height);
Bitmap.clear($00000000);
Bitmap.Canvas.Pen.Width:=0;
Bitmap.Canvas.Brush.Color:=$00107EFF; //FF7E10
Bitmap.Canvas.Brush.Style:=bsSolid;
Bitmap.Canvas.Ellipse(Rect(0,0,Self.Width,Self.Height));
Layer.BringToFront;
Layer.BringToFront;
//Layer.Scaled:=true;
// Layer.Bitmap:=Bitmap;
end;
procedure TBadgeTest.Paint;
var
R:TRect;
borderColor : Integer;
fillCircle : Integer;
fontColor : Integer;
fontSize : Integer;
Bitmap:TBitmapImage;
const
_FF7E10_COLOR:Integer = $00107EFF; //#FF7E10
begin
inherited;
borderColor:=_FF7E10_COLOR;
fillCircle:=_FF7E10_COLOR;
Canvas.Pen.Create;
Canvas.Pen.Style:=psClear;
Canvas.Pen.Color:=borderColor;
Canvas.Pen.Width:=0;
SetBkgLayer;
SetSecondLayer;
Canvas.Brush.Create;
Canvas.Brush.Style:= bsClear;
Canvas.Brush.Color:=fillCircle;
Canvas.Ellipse(0,0,Self.Width,Self.Height);
Canvas.Font.Color:=clWhite;
Canvas.Font.Name:='Arial';
Canvas.Font.Size:=8;
Canvas.Font.Quality := fqNonAntialiased;
Canvas.Font.Style := [fsBold];
R.Create(0, 0, Self.Width, Self.Height);
//DrawText(Canvas.Handle, PChar(FCaption), -1, R, vaCenter);
// Canvas.DrawText(FCaption, R, taCenter, vaCenter, False, False);
Canvas.TextOut(5, 5, FCaption);
//SetTextAlign(Canvas.Handle, ta_center);
//DrawText(Canvas.Handle, PChar(FCaption),
//R.Create(1, 10, 2, 26);
// Self.Width := Canvas.TextWidth(FCaption) + 30;
end;
A TGraphicControl has no window handle, and is simply painted on its Parent DC.
You can't bring a TGraphicContol in front of a TWinContol descendant (such as TPanel, TButton, TEdit etc).
Either use a TWinControl descendant as shown in your previous question which could be brought in front of other child TWinControl, or redesign your UI in such a way that eliminates a situation where another TWinControl overlaps with or on top of your customized graphic control.
P.S: visual controls are referred to as "Controls", not "Components" (which are non-visual)
I have noticed, in Delphi XE6 (and in other tools/languages that produce applications that run on Windows, and use native GDI font rendering) that the Win32 TextOut API does not seem to smooth any font larger than 149, that is, the Font.Size>149. Here is a screenshot showing two SpeedButtons, both with Font.Quality set to fqClearType, the one on the left Font.Size is set to 149, the one on the right is set with Font.Size is 150. That's one point difference. The height values are -199 and -200 respectively. This is simply to demonstrate with a Delphi component and form, what could also be demonstrated in a TPaintBox, with use of a Canvas.Font and a call to Win32 API DrawText, or with a pure Win32 API application that creates a window, and draws to a device context using DrawText.
The limitation of GDI is shown clearly here; Note that ClearType looks mediocre (horizontal anti-aliasing but no vertical) at size=149 , and ClearType turns off completely at 150:
My question is, is there any way to circumvent this limitation in the Win32 API GDI, using some raw Win32 function available on Windows 7 and up, to draw the text and always anti-alias? I assume here that logical font handling is being done properly, inside the VCL, because the same limit occurs in a C# application (using WinForms, which runs atop GDI) as I see when I try this in Delphi.
I would like to draw an anti-aliased character with a font size greater than 149, to a GDI canvas, either with Clear Type or with classic Anti-Aliasing. How would I do that?
Note that I have already set Font.Quality explicitly to both AntiAliased and ClearType modes, and that Win32 GDI api calls ignore these logical font properties about a certain size, apparently by design. Certain applications like Microsoft Word, however clearly have font-rendering capability to draw a 155 point font or larger, and still anti-alias in this case.
Update: I answered my own question showing how easy DirectWrite+GDI interop is. On windows 7 and windows 8, and later, DirectWrite actually provides both horizontal and vertical anti-aliasing, and I believe this is high quality on-screen font rendering mode is what apps like MS Word 2013 are using. I believe that someone could easily answer my question showing a GDI+ sample, and that would also fit my requirements above (as GDI+ is included in Windows 7 and 8).
A working approach that I have found that interoperates with GDI better than GDI+ does is to use DirectWrite, BUT THIS WORKS ONLY in Windows 7 and 8, and the sample code I present here has a simple GDI fallback mode (plain GDI, no anti-aliasing) that covers XP and Vista, to provide at least a graceful degradation; it still paints text on pre-Win7 operating systems, using GDI.
The original demo app is here, but it was using TForm which I changed to TWinControl, and it had no GDI fallback, just an exception.
http://cc.embarcadero.com/item/27491
The discussion/blog post by Pawel Glowacki who wrote the above demo is here:
http://blogs.embarcadero.com/pawelglowacki/2009/12/14/38872
A code snippet including a modified D2DUtils.pas from Pawel's demo with addition of a GDI fall-back feature (instead of blowing up with an exception) is shown here.
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
Winapi.D2D1,
Vcl.Direct2D;
type
TCanvasD2D = class(TWinControl) // a base class, using TWinControl instead of TForm.
private
FInitFlag: Boolean;
FGDIMode: Boolean; { Fallback }
FD2DCanvas: TDirect2DCanvas; { Used When D2D is available and GDIMode=False }
FGDICanvas: TCanvas; { Fallback canvas, used when FGDIMode=True }
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
procedure Resize; override;
procedure DoPaint(AHDC: HDC); virtual;
procedure CreateD2DResources; virtual;
procedure PaintD2D; virtual;
procedure PaintGDI; virtual;
function RenderTarget: ID2D1RenderTarget; // convenience function used during D2D Paints.
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Init;
property D2DCanvas: TDirect2DCanvas read FD2DCanvas;
property GDICanvas: TCanvas read FGDICanvas;
property GDIMode: Boolean read FGDIMode write FGDIMode;
{ Set to true to force GDI fallback, will automatically set true if D2D is not available, also }
end;
TCanvasD2DSample = class(TCanvasD2D) // subclass of TCanvasD2D that is a primitive "TLabel"
private
FFontBrush: ID2D1SolidColorBrush;// Brush generated from current value of FFontColor
FBackgroundColor:TColor; // clWhite
FFontColor:TColor; //clBlack;
FTextFormat: IDWriteTextFormat;
FFontName: string;
FFontSize: Integer; { Units?}
FDisplayText: String;
FLocale: String;
procedure SetFontName(const Value: String);
procedure SetFontSize(const Value: Integer);
procedure SetDisplayText(const Value: String);
protected
procedure PaintD2D; override;
procedure PaintGDI; override;
procedure CreateD2DResources; override;
function FontSizeToDip(FontSize:Integer ):Double;
public
constructor Create(AOwner: TComponent); override;
property TextFormat:IDWriteTextFormat read FTextFormat;
property FontSize:Integer read FFontSize write SetFontSize;
property FontName:String read FFontName write SetFontName;
property DisplayText: String read FDisplayText write SetDisplayText;
property BackgroundColor:TColor read FBackgroundColor write FBackgroundColor;
property FontColor:TColor read FFontColor write FFontColor; //clBlack;
property Locale: String read FLocale write FLocale; // string like 'en-us'
end;
implementation
constructor TCanvasD2D.Create(AOwner: TComponent);
begin
inherited;
end;
destructor TCanvasD2D.Destroy;
begin
FD2DCanvas.Free;
FD2DCanvas := nil;
FGDICanvas.Free;
FGDICanvas := nil;
inherited;
end;
procedure TCanvasD2D.Init;
begin
if not FInitFlag then
begin
FInitFlag := True;
if (not FGDIMode) and (TDirect2DCanvas.Supported) then
begin
if Assigned(FD2DCanvas) then
FD2DCanvas.Free;
FD2DCanvas := TDirect2DCanvas.Create(Handle);
CreateD2DResources;
end
else
begin
FGDIMode := True;
if Assigned(FGDICanvas) then
FGDICanvas.Free;
FGDICanvas := TCanvas.Create;
FGDICanvas.Handle := GetDC(Self.Handle);
end;
end;
end;
procedure TCanvasD2D.CreateD2DResources;
begin
// create Direct2D resources in descendant class
end;
function TCanvasD2D.RenderTarget: ID2D1RenderTarget;
begin
Result := D2DCanvas.RenderTarget;
end;
procedure TCanvasD2D.Resize;
var
HwndTarget: ID2D1HwndRenderTarget;
ASize: TD2D1SizeU;
begin
inherited;
if Assigned(D2DCanvas) then
if Supports(RenderTarget, ID2D1HwndRenderTarget, HwndTarget) then
begin
ASize := D2D1SizeU(ClientWidth, ClientHeight);
HwndTarget.Resize(ASize);
end;
Invalidate;
end;
procedure TCanvasD2D.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
if (not FGDIMode) then
// avoid flicker as described here:
// http://chrisbensen.blogspot.com/2009/09/touch-demo-part-i.html
Message.Result := 1
else
inherited;
end;
procedure TCanvasD2D.DoPaint(AHDC: HDC);
begin
Init;
if FGDIMode then
begin
FGDICanvas.Handle := AHDC;
PaintGDI;
end
else
begin
D2DCanvas.BeginDraw;
try
PaintD2D;
finally
D2DCanvas.EndDraw;
end;
end;
end;
procedure TCanvasD2D.PaintD2D;
begin
// implement painting code in descendant class
end;
procedure TCanvasD2D.PaintGDI;
begin
// implement in descendant.
end;
procedure TCanvasD2D.PaintWindow(DC: HDC);
begin
DoPaint(DC);
inherited;
end;
{ Custom Control Subclass }
procedure TCanvasD2DSample.CreateD2DResources;
begin
inherited;
D2DCanvas.RenderTarget.CreateSolidColorBrush(
D2D1ColorF(FFontColor, 1),
nil,
FFontBrush
);
DWriteFactory.CreateTextFormat(
PWideChar(FontName),
nil,
DWRITE_FONT_WEIGHT_REGULAR,
DWRITE_FONT_STYLE_NORMAL,
DWRITE_FONT_STRETCH_NORMAL,
FontSizeToDip( FontSize),
PWideChar(FLocale),
FTextFormat
);
FTextFormat.SetTextAlignment(DWRITE_TEXT_ALIGNMENT_CENTER);
FTextFormat.SetParagraphAlignment(DWRITE_PARAGRAPH_ALIGNMENT_CENTER);
end;
function TCanvasD2DSample.FontSizeToDip(FontSize: Integer): Double;
begin
result := FontSize * (96.0 / 72.0); { TODO: 96.0 should not be hard coded? }
end;
procedure TCanvasD2DSample.PaintD2D;
var
aRect: TD2D1RectF;
// ASize:D2D_SIZE_F;
begin
// fill with white color the whole window
RenderTarget.Clear(D2D1ColorF(FBackgroundColor));
RenderTarget.DrawText(
PWideChar(FDisplayText),
Length(FDisplayText),
FTextFormat,
D2D1RectF(0, 0, ClientWidth, ClientHeight),
FFontBrush
);
// RenderTarget.GetSize(ASize);
end;
procedure TCanvasD2DSample.PaintGDI;
begin
{ FALLBACK PAINT MODE}
GDICanvas.Lock;
GDICanvas.Font.Name := FFontName;
GDICanvas.Font.Size := FFontSize;
GDICanvas.Font.Color := FFontColor;
GDICanvas.Brush.Style := bsSolid;
GDICanvas.Brush.Color := FBackgroundColor;
GDICanvas.Rectangle(Self.ClientRect);
GDICanvas.TextOut(0,0, FDisplayText);
GDICanvas.Unlock;
end;
procedure TCanvasD2DSample.SetDisplayText(const Value: String);
begin
if Value<>FDisplayText then
begin
FDisplayText := Value;
Invalidate;
end;
end;
procedure TCanvasD2DSample.SetFontName(const Value: String);
begin
FFontName := Value;
end;
procedure TCanvasD2DSample.SetFontSize(const Value: Integer);
begin
FFontSize := Value;
end;
I asked this question before and deleted just because 1) it seemed like more work than I wanted to do, and 2) I went about asking my question poorly and it got closed. But, after doing more research, I've decided I will revisit this feature/question/how-to
I am attempting/wanting to create a blurred overlay as seen in the picture below. The obvious FMX.effect to use would be the 'Blur' effect. My question would be: how do I go about rendering the image the overlay would cover, or copying the image in an effective manner to blur for the overlay?
I have thought about using just two of the same bitmap, one for the background and one to blur but then I wouldn't be capture 'blur-ness' of controls or anything else on top of the original background. I also would think that if I were to have the overlay scroll into and out of view, then it would not look/appear as I would want it.
Considering the above, it all leads me to believe I need to dynamically capture the background to be blurred as the overlay scrolls/comes into view. How do I go about doing this and capturing current displayed screen content in Delphi XE6?
Not sure where to even start.
I do not own image *
After a little research on how to capture the parent control background I came up with the following code based on TMagnifierGlass class from FMX (Note that I made this code in XE5, you need to check XE6 compatibility):
TGlass = class(TControl)
private
FBlur: TBlurEffect;
FParentScreenshotBitmap: TBitmap;
function GetSoftness: Single;
procedure SetSoftness(Value: Single);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent);
destructor Destroy; override;
property Softness: Single read GetSoftness write SetSoftness;
end;
{ TGlass }
constructor TGlass.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// Create parent background
FParentScreenshotBitmap := TBitmap.Create(0, 0);
// Create blur
FBlur := TBlurEffect.Create(nil);
FBlur.Softness := 0.6;
end;
destructor TGlass.Destroy;
begin
FBlur.Free;
FParentScreenshotBitmap.Free;
inherited Destroy;
end;
function TGlass.GetSoftness: Single;
begin
Result := FBlur.Softness;
end;
procedure TGlass.SetSoftness(Value: Single);
begin
FBlur.Softness := Value;
end;
procedure TGlass.Paint;
var
ParentWidth: Single;
ParentHeight: Single;
procedure DefineParentSize;
begin
ParentWidth := 0;
ParentHeight := 0;
if Parent is TCustomForm then
begin
ParentWidth := (Parent as TCustomForm).ClientWidth;
ParentHeight := (Parent as TCustomForm).ClientHeight;
end;
if Parent is TControl then
begin
ParentWidth := (Parent as TControl).Width;
ParentHeight := (Parent as TControl).Height;
end;
end;
function IsBitmapSizeChanged(ABitmap: TBitmap; const ANewWidth, ANewHeight: Single): Boolean;
begin
Result := not SameValue(ANewWidth * ABitmap.BitmapScale, ABitmap.Width) or
not SameValue(ANewHeight * ABitmap.BitmapScale, ABitmap.Height);
end;
procedure MakeParentScreenshot;
var
Form: TCommonCustomForm;
Child: TFmxObject;
ParentControl: TControl;
begin
if FParentScreenshotBitmap.Canvas.BeginScene then
try
FDisablePaint := True;
if Parent is TCommonCustomForm then
begin
Form := Parent as TCommonCustomForm;
for Child in Form.Children do
if (Child is TControl) and (Child as TControl).Visible then
begin
ParentControl := Child as TControl;
ParentControl.PaintTo(FParentScreenshotBitmap.Canvas, ParentControl.ParentedRect);
end;
end
else
(Parent as TControl).PaintTo(FParentScreenshotBitmap.Canvas, RectF(0, 0, ParentWidth, ParentHeight));
finally
FDisablePaint := False;
FParentScreenshotBitmap.Canvas.EndScene;
end;
end;
begin
// Make screenshot of Parent control
DefineParentSize;
if IsBitmapSizeChanged(FParentScreenshotBitmap, ParentWidth, ParentHeight) then
FParentScreenshotBitmap.SetSize(Round(ParentWidth), Round(ParentHeight));
MakeParentScreenshot;
// Apply glass effect
Canvas.BeginScene;
try
FBlur.ProcessEffect(Canvas, FParentScreenshotBitmap, FBlur.Softness);
Canvas.DrawBitmap(FParentScreenshotBitmap, ParentedRect, LocalRect, 1, TRUE);
finally
Canvas.EndScene;
end;
end;
To use, just instantiate TGlass on top of any control, it should make the desired "glassy" effect that you are looking for
I created a TFrostGlass component which can also:
cache
have a background color tint
rounded corners
borders
You can see/download it here: https://github.com/Spelt/Frost-Glass