Change the background of an area containing already written text - delphi

(Delphi DX 10.3)
I have a big blank (white) canvas (on a Tpanel's descendant) where I draw some text (using Textout(), let's suppose text is always black) and graphics (lines, rectangles, nothing of so complex).
After drawing, I need to change the color of the white background of some specific areas, from white to another colour.
The effect I want to reach is much like an excel sheet with coloured cells. In the attached example, all the columns are created blank (white) like "value" and "difference", then the yellow (price) and the red (result) columns have been coloured.
If I could fill in the areas before writing the text, I would use SetBkMode(TRANSPARENT) and get an optimal result. Unfortunately I need to fill in the areas after writing the text and graphics.
The first solution I thought of was pixel-by-pixel replacement (using the Pixels[] function), but it's dramatically slow and graphically unsatisfactory.
So my question is: how can I color the background of an area containing already written text?
Here a Minimal Reproducibile Example.
Button 1 execute pixels substitution, very slow and with unsatisfactory graphical result.
Button 2 fills areas after writing text, using SetBkMode(TRANSPARENT). Perfect result, but I can't do it.
program BK_mode;
uses
Vcl.Forms,
main in 'main.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
////////////////////////////////
unit main;
interface
uses Windows, Forms, SysUtils, Vcl.StdCtrls, UiTypes, System.Classes, Vcl.Controls, Vcl.ExtCtrls, Graphics, Dialogs;
type
TForm1 = class(TForm)
btn_01: TButton;
btn_02: TButton;
procedure btn_02Click(Sender: TObject);
procedure btn_01Click(Sender: TObject);
private
procedure write_text(canvas: TCanvas;x, y : integer;i_fontsize : smallint;const str_text: String;style : TFontStyles;bo_transparent : boolean);
procedure switch_color(canvas : TCanvas;color_source, color_target : TColor);
procedure prepare_example(bo_transparent : boolean);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
const
BASE_COLOR = clWhite;
ALTERNATIVE_COLOR = clRed;
procedure TForm1.write_text(canvas: TCanvas;x, y : integer;i_fontsize : smallint;const str_text: String;style : TFontStyles;bo_transparent : boolean);
begin
var lo_old_BK_color : TColor := canvas.Brush.Color;
var lo_old_BK_mode := GetBKMode(canvas.Handle);
if bo_transparent then SetBKMode(canvas.Handle, TRANSPARENT)
else begin
SetBKMode(canvas.Handle, OPAQUE);
canvas.Brush.Color := BASE_COLOR
end;
canvas.Font.Color := clBlack;canvas.Font.Size := i_fontsize;canvas.Font.Style := style;
TextOut(canvas.Handle, x, y, PChar(str_text), Length(str_text));
if NOT bo_transparent then canvas.Brush.Color := lo_old_BK_color;
SetBKMode(canvas.Handle, lo_old_BK_mode)
end;
procedure TForm1.switch_color(canvas : TCanvas;color_source, color_target : TColor);
begin
for var x := 0 to clientWidth-1 do
for var y := 0 to clientHeight - 1 do
if (canvas.Pixels[x, y] = color_source) then canvas.Pixels[x, y] := color_target
end;
procedure TForm1.prepare_example(bo_transparent : boolean);
begin
if bo_transparent then Color := ALTERNATIVE_COLOR else Color := BASE_COLOR;
invalidate;
application.MessageBox('Click me', 'Test');
canvas.Rectangle(10, 10, 200, 100);
canvas.MoveTo(10, 110);canvas.LineTo(200, 140);
canvas.MoveTo(10, 140);canvas.LineTo(200, 110);
write_text(canvas, 30, 30, 14, 'This is a text!', [], bo_transparent);
write_text(canvas, 30, 60, 11, 'This is another text!', [fsBold, fsItalic], bo_transparent)
end;
procedure TForm1.btn_01Click(Sender: TObject);
begin
prepare_example(FALSE);
switch_color(canvas, BASE_COLOR, ALTERNATIVE_COLOR)
end;
procedure TForm1.btn_02Click(Sender: TObject);
begin
prepare_example(TRUE)
end;
end.
/////////////////////////////////////////////////////////
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 283
ClientWidth = 208
Color = clWhite
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
DesignSize = (
208
283)
PixelsPerInch = 96
TextHeight = 13
object btn_01: TButton
Left = 17
Top = 161
Width = 178
Height = 51
Anchors = [akLeft, akRight, akBottom]
Caption = '1. write text and fill area'
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -16
Font.Name = 'Arial'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 0
WordWrap = True
OnClick = btn_01Click
end
object btn_02: TButton
Left = 17
Top = 220
Width = 178
Height = 51
Anchors = [akLeft, akRight, akBottom]
Caption = '2. fill area then write text'
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -16
Font.Name = 'Arial'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 1
WordWrap = True
OnClick = btn_02Click
end
end

What you are asking for is simply not doable this way. You need to redraw the entire Canvas, drawing your backgrounds BEFORE drawing lines+text on top. Once you have drawn, you need a repaint to do everything over. DO NOT draw on a Canvas from outside of a Paint event.
Your example draws on a TForm.Canvas, so use the TForm.OnPaint event. For a TPanel descendant, override the virtual Paint() method instead. Either way, keep some variables with the desired settings, use those variable while drawing, and call Invalidate() after updating the variables and you want to trigger a repaint.
For example:
unit main;
interface
uses Windows, Forms, SysUtils, Vcl.StdCtrls, UiTypes, System.Classes, Vcl.Controls, Vcl.ExtCtrls, Graphics, Dialogs;
type
TForm1 = class(TForm)
btn_01: TButton;
btn_02: TButton;
procedure btn_02Click(Sender: TObject);
procedure btn_01Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
FDrawTransparent : Boolean;
FDrawColor : TColor;
procedure write_text(ACanvas: TCanvas; x, y : integer; i_fontsize : smallint; const str_text: String; style : TFontStyles; bo_transparent : boolean);
procedure prepare_example(bo_transparent : boolean; color_target : TColor);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
const
BASE_COLOR = clWhite;
ALTERNATIVE_COLOR = clRed;
procedure TForm1.FormCreate(Sender: TObject);
begin
FDrawTransparent := False;
FDrawColor := BASE_COLOR;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
Canvas.Brush.Color := Self.Color;
Canvas.Rectangle(10, 10, 200, 100);
Canvas.MoveTo(10, 110);
Canvas.LineTo(200, 140);
Canvas.MoveTo(10, 140);
Canvas.LineTo(200, 110);
write_text(Canvas, 30, 30, 14, 'This is a text!', [], FDrawTransparent);
write_text(Canvas, 30, 60, 11, 'This is another text!', [fsBold, fsItalic], FDrawTransparent);
end;
procedure TForm1.write_text(ACanvas: TCanvas; x, y : integer; i_fontsize : smallint; const str_text: String;style : TFontStyles; bo_transparent : boolean);
begin
var lo_old_BK_color := ACanvas.Brush.Color;
var lo_old_BK_mode := GetBKMode(ACanvas.Handle);
if bo_transparent then
SetBKMode(ACanvas.Handle, TRANSPARENT)
else begin
SetBKMode(ACanvas.Handle, OPAQUE);
ACanvas.Brush.Color := FDrawColor;
end;
ACanvas.Font.Color := clBlack;
ACanvas.Font.Size := i_fontsize;
ACanvas.Font.Style := style;
TextOut(ACanvas.Handle, x, y, PChar(str_text), Length(str_text));
if NOT bo_transparent then ACanvas.Brush.Color := lo_old_BK_color;
SetBKMode(ACanvas.Handle, lo_old_BK_mode);
end;
procedure TForm1.prepare_example(bo_transparent : boolean; color_target: TColor);
begin
FDrawTransparent := bo_transparent;
FDrawColor := color_target;
if bo_transparent then Color := ALTERNATIVE_COLOR else Color := BASE_COLOR;
Invalidate;
Application.MessageBox('Click me', 'Test');
end;
procedure TForm1.btn_01Click(Sender: TObject);
begin
prepare_example(False, ALTERNATIVE_COLOR);
end;
procedure TForm1.btn_02Click(Sender: TObject);
begin
prepare_example(True, BASE_COLOR);
end;
end.

Related

Image slide effect. BitBlt shimmers

I want to create a slide effect: one bitmap is painted from right to left on a form's canvas. For this I use BitBlt.
I call this function in a Timer (20ms):
var ViewPort: TRect;
ViewPort.Left := 0;
ViewPort.Top := 0;
ViewPort.Width := 1400;
ViewPort.Height := 900;
x: integer := spnStep.Value; //SpinBox.Value = 10
procedure TfrmTester.Slide(BMP: TBitmap; ViewPort: TRect);
begin
Inc(x, spnStep.Value);
if x >= ViewPort.Width then
begin
x:= ViewPort.Width;
Timer.Enabled:= FALSE;
end;
BitBlt(frmTester.Canvas.Handle,
ViewPort.Width-x, 0, // X, Y
x, ViewPort.Height, // cX, cY
BMP.Canvas.Handle, 0, 0, SRCCOPY);
end;
However, the image does not progress smoothly. It has some kind of flicker, but not the kind of flicker that we know in the VCL. It is difficult to describe it. It is like the image moves two pixels forward and then one pixel backward.
How to make the image move smoothly?
Could the actually be caused by the refresh rate of the monitor?
Update: I don't know why, but it is caused by the timer.
If I call Slide() in a 'for' loop then the animation is smooth.
I know that the timer has an accuracy of ~15ms, but I still don't get it why it makes the image to shimmer.
If I add a sleed(1) inside the loop the shimmer effect appears again, and it is even worse. It really looks like the image is drawn twice.
First, you should only paint on the form in the form's OnPaint handler. I don't know if you do that or not, but you should do so.
Second, you cannot really rely on the temporal distance between successive WM_TIMER messages being very precise or even constant. So it is better to check the actual time each time you paint. For instance, you may use the formula Position = Original Position + Velocity × Time known from school physics.
Also, to avoid flickering, you should probably handle WM_ERASEBKGND.
Putting these together,
unit AnimatedRabbit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Dialogs, ExtCtrls;
type
TMainForm = class(TForm)
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
FRabbit: TBitmap;
FStartTime: TDateTime;
const
Speed = -100;
function GetRabbitLeft: Double;
protected
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
public
end;
var
MainForm: TMainForm;
implementation
uses
DateUtils;
{$R *.dfm}
procedure TMainForm.FormCreate(Sender: TObject);
begin
FRabbit := TBitmap.Create;
FRabbit.LoadFromFile('K:\rabbit.bmp');
FStartTime := Now;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
FreeAndNil(FRabbit);
end;
procedure TMainForm.FormPaint(Sender: TObject);
var
x: Integer;
begin
x := Round(GetRabbitLeft);
BitBlt(
Canvas.Handle,
x,
0,
FRabbit.Width,
FRabbit.Height,
FRabbit.Canvas.Handle,
0,
0,
SRCCOPY
);
Canvas.Brush.Color := Color;
if x > 0 then
Canvas.FillRect(Rect(0, 0, x - 1, ClientHeight));
if x + FRabbit.Width < ClientWidth then
Canvas.FillRect(Rect(x + FRabbit.Width, 0, ClientWidth, ClientHeight));
end;
function TMainForm.GetRabbitLeft: Double;
begin
Result := ClientWidth + Speed * SecondSpan(Now, FStartTime);
end;
procedure TMainForm.Timer1Timer(Sender: TObject);
begin
Invalidate;
if GetRabbitLeft + FRabbit.Width < 0 then
Timer1.Enabled := False;
end;
procedure TMainForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
end.
I think this is as good as you can make it using GDI (a graphics API from the 1980s). I bet it will look better in Direct2D (or OpenGL, if you prefer that).
Update
After further investigation, I suspect that the usual timer isn't good enough. The problem is two-fold: (1) The best FPS obtainable by a normal timer is too low. (2) The fact that the duration between two consecutive WM_TIMER messages isn't constant causes visual issues.
If I instead use a high-resolution multimedia timer, ignoring the fact that they are deprecated, I get a nicer result:
unit AnimatedRabbit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Dialogs, ExtCtrls;
const
WM_DOINVALIDATE = WM_USER + 1;
type
TMainForm = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FRabbit: TBitmap;
FStartTime: TDateTime;
FMMEvent: Cardinal;
const
Speed = -100;
function GetRabbitLeft: Double;
protected
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMDoInvalidate(var Message: TMessage); message WM_DOINVALIDATE;
public
end;
var
MainForm: TMainForm;
implementation
uses
DateUtils, MMSystem, Math;
{$R *.dfm}
procedure RepaintFunc(wTimerID: UINT; msg: UINT; dwUser: NativeUINT;
dw1, dw2: NativeUINT); stdcall;
begin
PostMessage(MainForm.Handle, WM_DOINVALIDATE, 0, 0);
end;
procedure TMainForm.FormCreate(Sender: TObject);
const
TargetResolution = 1;
var
tc: TTimeCaps;
res: Cardinal;
begin
FRabbit := TBitmap.Create;
FRabbit.LoadFromFile('K:\rabbit.bmp');
FStartTime := Now;
if timeGetDevCaps(#tc, SizeOf(tc)) <> TIMERR_NOERROR then
Exit;
res := EnsureRange(TargetResolution, tc.wPeriodMin, tc.wPeriodMax);
if timeBeginPeriod(res) <> TIMERR_NOERROR then
Exit;
FMMEvent := timeSetEvent(10, res, RepaintFunc, 0, TIME_PERIODIC);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
timeKillEvent(FMMEvent);
FreeAndNil(FRabbit);
end;
procedure TMainForm.FormPaint(Sender: TObject);
var
x: Integer;
begin
x := Round(GetRabbitLeft);
BitBlt(
Canvas.Handle,
x,
0,
FRabbit.Width,
FRabbit.Height,
FRabbit.Canvas.Handle,
0,
0,
SRCCOPY
);
Canvas.Brush.Color := Color;
if x > 0 then
Canvas.FillRect(Rect(0, 0, x - 1, ClientHeight));
if x + FRabbit.Width < ClientWidth then
Canvas.FillRect(Rect(x + FRabbit.Width, 0, ClientWidth, ClientHeight));
end;
function TMainForm.GetRabbitLeft: Double;
begin
Result := ClientWidth + Speed * SecondSpan(Now, FStartTime);
end;
procedure TMainForm.WMDoInvalidate(var Message: TMessage);
begin
Invalidate;
end;
procedure TMainForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
end.
Update 2
And here is the non-deprecated version:
unit AnimatedRabbit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Dialogs, ExtCtrls;
const
WM_DOINVALIDATE = WM_USER + 1;
type
TMainForm = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FRabbit: TBitmap;
FStartTime: TDateTime;
FTimer: THandle;
const
Speed = -100;
function GetRabbitLeft: Double;
protected
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMDoInvalidate(var Message: TMessage); message WM_DOINVALIDATE;
public
end;
var
MainForm: TMainForm;
implementation
uses
DateUtils, Math;
{$R *.dfm}
procedure RepaintFunc(Context: Pointer; Success: Boolean); stdcall;
begin
PostMessage(MainForm.Handle, WM_DOINVALIDATE, 0, 0);
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
FRabbit := TBitmap.Create;
FRabbit.LoadFromFile('K:\rabbit.bmp');
FStartTime := Now;
if not CreateTimerQueueTimer(FTimer, 0, RepaintFunc, nil, 0, 10, 0) then
RaiseLastOSError;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
DeleteTimerQueueTimer(0, FTimer, INVALID_HANDLE_VALUE);
FreeAndNil(FRabbit);
end;
procedure TMainForm.FormPaint(Sender: TObject);
var
x: Integer;
begin
x := Round(GetRabbitLeft);
BitBlt(
Canvas.Handle,
x,
0,
FRabbit.Width,
FRabbit.Height,
FRabbit.Canvas.Handle,
0,
0,
SRCCOPY
);
Canvas.Brush.Color := Color;
if x > 0 then
Canvas.FillRect(Rect(0, 0, x - 1, ClientHeight));
if x + FRabbit.Width < ClientWidth then
Canvas.FillRect(Rect(x + FRabbit.Width, 0, ClientWidth, ClientHeight));
end;
function TMainForm.GetRabbitLeft: Double;
begin
Result := ClientWidth + Speed * SecondSpan(Now, FStartTime);
end;
procedure TMainForm.WMDoInvalidate(var Message: TMessage);
begin
Invalidate;
end;
procedure TMainForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
end.
Also, I previously said that the precise result depends on CPU, GPU, OS, and monitor. But it also depends on the eye and brain. The thing that makes this animation require such a high-quality timer is the fact that the motion is a simple translation with constant velocity, and the eye + brain can easily spot any imperfection. If we had animated a bouncing ball or SHM, an old-school timer would have been enough.
You should not be drawing on the Form's Canvas from outside of its OnPaint event at all. All of the drawing should be in the OnPaint event only. Have your timer save the desired information into variables that the Form can access, and then Invalidate() the Form, and let its OnPaint event draw the image using the latest saved information.
Alternatively, simply display your BMP inside a TImage control, and then have the timer set that control's Left/Top/Width/Height properties as needed. Let the TImage handle the drawing of the image for you.
You can use AnimateWindow
Here's the DFM. Just add client aligned TPicture inside the TPanel
object Form30: TForm30
Left = 0
Top = 0
Caption = 'Form30'
ClientHeight = 337
ClientWidth = 389
Color = clBtnFace
DoubleBuffered = True
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 0
Top = 0
Width = 389
Height = 289
Align = alTop
BevelOuter = bvNone
Color = clRed
FullRepaint = False
ParentBackground = False
ShowCaption = False
TabOrder = 0
Visible = False
end
object Button1: TButton
Left = 136
Top = 304
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 1
OnClick = Button1Click
end
end
And the Button1.OnClick handler:
procedure TForm30.Button1Click(Sender: TObject);
begin
AnimateWindow(Panel1.Handle, 1000, AW_SLIDE or AW_HOR_POSITIVE or AW_ACTIVATE);
end;

How to Implement Text Box with Gray Text Hint?

In many website, I can see text box with hint in gray text. The hint will tell the user what should be inputted and whenever user tries to input anything, the hint will disappear.
Below is a sample of it:
I just wonder how to implement such a feature in Windows desktop application. I am using Delphi XE3 and it is possible to implement such a feature with TTextBox? Or is there such a VCL component available?
Here is an implementation that works for Windows XP (and also Windows 7 and 8.1, haven't tested it on Windows 10). Beware: I mostly use it in Windows XP and 8.1 and with Delphi 2007 and XE2. There may be bugs that I haven't seen yet.
It's also probably not the most elegant solution but it works and is easy to understand.
Prerequisites: Delphi Custom Containers Pack
Just save the following to u_dzCueEdit.dfm and u_dzCueEdit.pas, create a runtime package with it, create a corresponding design time package with a Register procedure and install it.
dfm file:
object dzCueEdit: TdzCueEdit
Left = 0
Top = 0
Width = 258
Height = 21
TabOrder = 0
OnResize = BoxResize
object ed_Cue: TEdit
Left = 1
Top = 1
Width = 256
Height = 19
Align = alClient
TabOrder = 0
OnChange = ed_CueChange
OnClick = ed_CueClick
OnEnter = ed_CueEnter
OnExit = ed_CueExit
end
object p_Cue: TPanel
Left = 64
Top = 0
Width = 242
Height = 21
BevelOuter = bvNone
Color = clMoneyGreen
ParentBackground = False
TabOrder = 1
OnClick = p_CueClick
OnEnter = p_CueEnter
object l_Cue: TLabel
AlignWithMargins = True
Left = 88
Top = 0
Width = 93
Height = 13
Margins.Left = 1
Margins.Top = 1
Margins.Right = 1
Margins.Bottom = 1
Caption = 'Cue text goes here'
Font.Charset = DEFAULT_CHARSET
Font.Color = clGray
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
OnClick = l_CueClick
end
end
end
pas file:
unit c_dzCueEdit;
interface
uses
Windows,
Messages,
SysUtils,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ExtCtrls,
StdCtrls,
ccBoxes;
type
TdzCueEdit = class(TBox)
p_Cue: TPanel;
l_Cue: TLabel;
procedure ed_CueClick(Sender: TObject);
procedure l_CueClick(Sender: TObject);
published
ed_Cue: TEdit;
procedure p_CueEnter(Sender: TObject);
procedure p_CueClick(Sender: TObject);
procedure ed_CueChange(Sender: TObject);
procedure ed_CueEnter(Sender: TObject);
procedure ed_CueExit(Sender: TObject);
procedure BoxResize(Sender: TObject);
private
procedure CheckCueBanner;
function GetCue: string;
function GetText: string;
procedure SetCue(const _Value: string);
procedure SetText(const _Value: string);
protected
public
constructor Create(_Owner: TComponent); override;
published
property Text: string read GetText write SetText;
property Cue: string read GetCue write SetCue;
end;
implementation
{$R *.DFM}
{ TdzCueEdit }
constructor TdzCueEdit.Create(_Owner: TComponent);
begin
inherited;
BevelOuter := bvNone;
l_Cue.Align := alClient;
p_Cue.Color := ed_Cue.Color;
end;
procedure TdzCueEdit.BoxResize(Sender: TObject);
var
Rect: TRect;
begin
Rect := ed_Cue.ClientRect;
// p_Cue.SetBounds(Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
p_Cue.SetBounds(Rect.Left + 4, Rect.Top + 3, Rect.Right - Rect.Left - 2, Rect.Bottom - Rect.Top - 2);
end;
procedure TdzCueEdit.CheckCueBanner;
begin
if ed_Cue.Text <> '' then
p_Cue.Visible := False
else begin
// if ed_Cue.Focused then
// p_Cue.Visible := False
// else
p_Cue.Visible := True;
end;
end;
procedure TdzCueEdit.ed_CueChange(Sender: TObject);
begin
CheckCueBanner;
end;
procedure TdzCueEdit.ed_CueClick(Sender: TObject);
begin
CheckCueBanner;
end;
procedure TdzCueEdit.ed_CueEnter(Sender: TObject);
begin
CheckCueBanner;
end;
procedure TdzCueEdit.ed_CueExit(Sender: TObject);
begin
CheckCueBanner;
end;
function TdzCueEdit.GetCue: string;
begin
Result := l_Cue.Caption;
end;
procedure TdzCueEdit.SetCue(const _Value: string);
begin
l_Cue.Caption := _Value;
end;
function TdzCueEdit.GetText: string;
begin
Result := ed_Cue.Text;
end;
procedure TdzCueEdit.l_CueClick(Sender: TObject);
begin
ed_Cue.SetFocus;
CheckCueBanner;
end;
procedure TdzCueEdit.SetText(const _Value: string);
begin
ed_Cue.Text := _Value;
end;
procedure TdzCueEdit.p_CueClick(Sender: TObject);
begin
ed_Cue.SetFocus;
CheckCueBanner;
end;
procedure TdzCueEdit.p_CueEnter(Sender: TObject);
begin
ed_Cue.SetFocus;
CheckCueBanner;
end;
end.

Allow multiple child controls to detect when their parent control resizes

I'm writing a TSplitter descendant that proportionally resizes its aligned control when its parent control resizes. In order to detect the parent resize I subclass the parents WinProc procedure
FOldWindowProc := Parent.WindowProc;
Parent.WindowProc := SubclassedParentWndProc;
This works perfectly when there is a single splitter parented by the parent. However, when there are one or more splitters, only one of them works correctly.
How can I receive a notification to all the splitter controls that the parent has resized?
Here's my code
unit ProportionalSplitterU;
interface
uses
Windows, SysUtils, Controls, Messages, Classes, CommCtrl, ExtCtrls;
type
TSPlitterHelper = class helper for TSplitter
public
function FindControlEx: TControl;
end;
TProportionalSplitter = class(TSplitter)
private
FOldWindowProc: TWndMethod;
FControlRatio: Double;
FProportionalResize: Boolean;
procedure SubclassedParentWndProc(var Msg: TMessage);
procedure SetRatio;
procedure SetProportionalResize(const Value: Boolean);
protected
procedure SetParent(AParent: TWinControl); override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure StopSizing; override;
public
constructor Create(AOwner: TComponent); override;
published
property ProportionalResize: Boolean read FProportionalResize write SetProportionalResize;
end;
implementation
{ TProportionalSplitter }
constructor TProportionalSplitter.Create(AOwner: TComponent);
begin
inherited;
FProportionalResize := True;
end;
procedure TProportionalSplitter.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
if (Operation = opRemove) and
(AComponent = Parent) then
begin
Parent.WindowProc := FOldWindowProc;
FOldWindowProc := nil;
end;
end;
procedure TProportionalSplitter.SetParent(AParent: TWinControl);
begin
FControlRatio := -1;
if Assigned(Parent) then
begin
Parent.WindowProc := FOldWindowProc;
end;
inherited SetParent(AParent);
if Assigned(AParent) then
begin
FOldWindowProc := Parent.WindowProc;
Parent.WindowProc := SubclassedParentWndProc;
SetRatio;
end;
end;
procedure TProportionalSplitter.SetProportionalResize(const Value: Boolean);
begin
FProportionalResize := Value;
SetRatio;
end;
procedure TProportionalSplitter.SetRatio;
var
ActiveControl: TControl;
begin
if FProportionalResize then
begin
ActiveControl := FindControlEx;
if (Parent <> nil) and
(ActiveControl <> nil) then
begin
case Align of
alTop,
alBottom: FControlRatio := ActiveControl.Height / Parent.Height;
alLeft,
alRight: FControlRatio := ActiveControl.Width / Parent.Width;
end;
end;
end
else
begin
FControlRatio := -1;
end;
end;
procedure TProportionalSplitter.StopSizing;
begin
inherited;
SetRatio;
end;
procedure TProportionalSplitter.SubclassedParentWndProc(Var Msg: TMessage);
begin
FOldWindowProc(Msg);
if Msg.Msg = WM_SIZE then
begin
if FControlRatio <> -1 then
begin
case Align of
alTop,
alBottom: FindControlEx.Width := Round(Parent.Height * FControlRatio);
alLeft,
alRight: FindControlEx.Width := Round(Parent.Width * FControlRatio);
end;
end
else
begin
SetRatio;
end;
end;
end;
{ TSPlitterHelper }
function TSPlitterHelper.FindControlEx: TControl;
begin
Result := Self.FindControl;
end;
end.
Demo .pas
unit Unit2;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
ProportionalSplitterU;
type
TForm2 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
procedure FormCreate(Sender: TObject);
private
FSplitter: TProportionalSplitter;
FSplitter2: TProportionalSplitter;
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
procedure TForm2.FormCreate(Sender: TObject);
begin
FSplitter := TProportionalSplitter.Create(Self);
FSplitter.Parent := Self;
FSplitter.Align := alLeft;
FSplitter.Left := Panel1.Width + 1;
FSplitter.Width := 20;
FSplitter.ResizeStyle := rsUpdate;
FSplitter2 := TProportionalSplitter.Create(Self);
FSplitter2.Parent := Self;
FSplitter2.Align := alTop;
FSplitter2.Top := Panel3.Height + 1;
FSplitter2.Height := 20;
FSplitter2.ResizeStyle := rsUpdate;
end;
end.
Demo .dfm
object Form2: TForm2
Left = 0
Top = 0
Caption = 'Form2'
ClientHeight = 478
ClientWidth = 674
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 120
TextHeight = 16
object Panel1: TPanel
Left = 0
Top = 193
Width = 249
Height = 285
Align = alLeft
Caption = 'Panel1'
TabOrder = 0
ExplicitTop = 0
ExplicitHeight = 478
end
object Panel2: TPanel
Left = 249
Top = 193
Width = 425
Height = 285
Align = alClient
Caption = 'Panel2'
TabOrder = 1
ExplicitTop = 0
ExplicitHeight = 478
end
object Panel3: TPanel
Left = 0
Top = 0
Width = 674
Height = 193
Align = alTop
Caption = 'Panel3'
TabOrder = 2
end
end
You code is working perfectly correctly as far as intercepting parent window messages is concerned. There is however a problem in your window hook code which may have lead you to incorrectly conclude that this was not working as one of your panels in your test case was not being proportionally resized.
The problem is in this code:
case Align of
alTop, vvvvv
alBottom : FindControlEx.Width := Round(Parent.Height * FControlRatio);
^^^^^
alLeft,
alRight : FindControlEx.Width := Round(Parent.Width * FControlRatio);
end;
Notice that in both cases you are setting the WIDTH of the active control. For Top/Bottom aligned splitter you should instead be setting the HEIGHT.
case Align of
alTop, vvvvvv
alBottom : FindControlEx.Height := Round(Parent.Height * FControlRatio);
^^^^^^
alLeft,
alRight : FindControlEx.Width := Round(Parent.Width * FControlRatio);
end;
This is why your top panel was not resizing its height, even though the WM_SIZE message is being received.

Delphi XE2 VCL styles, updating caption blocks other controls invalidation

Found a glitch with VCL styles: when you update the form caption, other controls previously redrawn within the same procedure don't get repainted, and you are forced to call Repaint, losing valuable processing time to redraw.
Example: (set project options/vcl style manually)
unit Unit11;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;
type
TForm11 = class(TForm)
Button1: TButton;
Panel1: TPanel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form11: TForm11;
implementation
{$R *.dfm}
procedure TForm11.Button1Click(Sender: TObject);
begin
Panel1.Caption := 'test';
caption := 'glitch';
end;
end.
object Form11: TForm11
Left = 0
Top = 0
Caption = 'Form11'
ClientHeight = 89
ClientWidth = 352
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Button1: TButton
Left = 8
Top = 8
Width = 121
Height = 57
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object Panel1: TPanel
Left = 135
Top = 8
Width = 185
Height = 57
Caption = 'Panel1'
TabOrder = 1
end
end
program Project10;
uses
Vcl.Forms,
Unit11 in 'Unit11.pas' {Form11},
Vcl.Themes,
Vcl.Styles;
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
TStyleManager.TrySetStyle('Cobalt XEMedia');
Application.CreateForm(TForm11, Form11);
Application.Run;
end.
Set the caption calls in the sequence.
First form.caption, then child.caption.
Once you've called the wrong sequence, then stopped working the correct sequence. That's why I use here, the "set default" button.
This proceed, as long as there is no fix for it, I can live with that.
procedure TForm11.Button1Click(Sender: TObject);
begin // wrong order
Panel1.Caption := 'test';
caption := 'glitch';
end;
procedure TForm11.Button2Click(Sender: TObject);
begin // right order
caption := 'glitch';
Panel1.Caption := 'test';
end;
procedure TForm11.Button3Click(Sender: TObject);
var
i:integer;
begin // count no refresh
for i:= 1 to 300 do begin
caption := 'glitch '+intToStr(i);
Panel1.Caption := 'test '+intToStr(i);
end;
end;
procedure TForm11.Button4Click(Sender: TObject);
var
i:integer;
begin // count with refresh
for i:= 1 to 300 do begin
caption := 'glitch '+intToStr(i);
Panel1.Caption := 'test '+intToStr(i);
Panel1.Refresh;
end;
end;
procedure TForm11.Button5Click(Sender: TObject);
begin // set default
caption := 'Form11';
Panel1.Caption := 'Panel1';
Panel1.Refresh;
end;
end.
If you found another solution. Please tell me.

ProgressBar In tListview subitem Delphi

I've been looking at how to put a progress bar in a TListView in Delphi, and I've got some code that works, BUT I want to add it to a SubItem and cannot figure out how.
object Form1: TForm1
Left = 221
Top = 113
Caption = 'Form1'
ClientHeight = 203
ClientWidth = 482
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
DesignSize = (
482
203)
PixelsPerInch = 96
TextHeight = 13
object ListView1: TListView
Left = 16
Top = 16
Width = 449
Height = 177
Anchors = [akLeft, akTop, akRight, akBottom]
Columns = <>
FullDrag = True
TabOrder = 0
OnCustomDrawItem = ListView1CustomDrawItem
end
end
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, StdCtrls, CommCtrl;
type
TForm1 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
procedure ListView1CustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
private
{ Private declarations }
procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
procedure AdjustProgressBar(item: TListItem; r: TRect);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var
i: Byte;
r: TRect;
pb: TProgressBar;
begin
Listview1.Columns.Add.Width := 100;
Listview1.Columns.Add.Width := 200;
Listview1.ViewStyle := vsReport;
Randomize;
for i:=0 to 40 do
begin
Listview1.Items.Add.Caption := 'Texte ' + IntToStr(i);
r := Listview1.Items[i].DisplayRect(drBounds);
pb := TProgressBar.Create(Self);
pb.Parent := Listview1;
pb.Position := Random(pb.Max);
Listview1.Items[i].Data := pb;
AdjustProgressBar(Listview1.Items[i], r);
end;end;
procedure TForm1.WMNotify(var Message: TWMNotify);
var
i: Integer;
r: TRect;
begin
case Message.NMHdr.code of
HDN_ITEMCHANGED, HDN_ITEMCHANGING:
begin
for i:=0 to Listview1.Items.Count-1 do
begin
r := Listview1.Items[i].DisplayRect(drBounds);
AdjustProgressBar(Listview1.Items[i], r);
end;
ListView1.Repaint;
end;end;
inherited;
end;
procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
var
r: TRect;
pb: TProgressBar;
begin
r := Item.DisplayRect(drBounds);
if r.Top>=Listview1.BoundsRect.Top then
AdjustProgressBar(Item, r);
end;
procedure TForm1.AdjustProgressBar(item: TListItem; r: TRect);
var
pb: TProgressBar;
begin
r.Left := r.Left + Listview1.columns[0].Width;
r.Right := r.Left + Listview1.columns[1].Width;
pb := item.Data;
pb.BoundsRect := r;
end;
end.
The code I want it to work with is:
...
with listview1.Items.Add do
begin
Caption := IntToStr(listview1.Items.Count);
SubItems.Add('blah');
SubItems.Add('blah');
SubItems.Add('blah');
{Add SubItem Progress Bar here Position 4 out of 10}
end;
The code you've shown doesn't really add a progress bar "to" a subitem. Rather, it takes a standalone progress bar and moves it to cover the space of the first two columns. That's what your AdjustProgressBar function does. It receives the bounding rectangle of the list item, which I think corresponds to the total width of all the columns. Then, it shifts the left side of the rectangle by the width of the first column, and it shifts the right side of the rectangle by the width of the second column.
You can adjust the coordinates of the progress bar however you want. For example, to make it cover the third column, shift the left side by the widths of the first two columns, and then set the right side to the left coordinate plus the third column's width.
But for that to work, you still need for the list item to have a subitem. You're just putting a progress bar on top of it, and you already have code to do that. You can't add an object as a subitem; a subitem is always text. The text can be blank, although for the benefit of screen readers that know how to read list views, it would be nice if you updated the text with the progress bar's value.
I'd take a look at the OnDrawItem and completely redraw the control myself.
Check this post.

Resources