Make a TDBEdit show the characters remaining - delphi

Question

The problem I'm wanting to solve is to display to the user the remaining characters left in a field as they are typing into a TDBEdit.
Currently I'm doing something along the lines of
lCharRemaining.Caption := Field.Size - length(dbedit.text);
i.e. updating a label in the OnChange event for the TDBEdit, which works perfectly fine. However I'm wanting to do this for a number of TDBEdits and tried to write a custom component that would display the length remaining within the edit box on the right. It however interferes with editing. I was perhaps thinking that I could display a hint while someone was typing indicating the remaining space in the field - any suggestions?
Here is the code for my component (if someone can suggest improvements).
unit DBEditWithLenghtCountdown;
interface
uses
SysUtils, Classes, Controls, StdCtrls, Mask, DBCtrls, messages, Graphics;
type
TDBEditWithLenghtCountdown = class(TDBEdit)
private
{ Private declarations }
FCanvas: TCanvas;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
protected
{ Protected declarations }
property Canvas: TCanvas read FCanvas;
procedure WndProc(var Message: TMessage); override;
public
{ Public declarations }
function CharactersRemaining : integer;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
end;
procedure Register;
implementation
uses
db, Types;
procedure Register;
begin
RegisterComponents('Samples', [TDBEditWithLenghtCountdown]);
end;
{ TDBEditWithLenghtCountdown }
function TDBEditWithLenghtCountdown.CharactersRemaining: integer;
begin
result := -1;
if Assigned(Field)then
begin
result := Field.Size - Length(Text);
end;
end;
constructor TDBEditWithLenghtCountdown.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanvas := TControlCanvas.Create;
TControlCanvas(FCanvas).Control := Self;
end;
destructor TDBEditWithLenghtCountdown.Destroy;
begin
FCanvas.Free;
inherited;
end;
procedure TDBEditWithLenghtCountdown.WMPaint(var Message: TWMPaint);
var
R: TRect;
Remaining : string;
WidthOfText: Integer;
x: Integer;
begin
inherited;
if not focused then
exit;
Remaining := IntToStr(CharactersRemaining);
R := ClientRect;
Inc(R.Left, 1);
Inc(R.Top, 1);
Canvas.Brush.Assign(Self.Brush);
Canvas.Brush.Style := bsClear;
Canvas.Font.Assign(Self.Font);
Canvas.Font.Color := clRed;
WidthOfText := Canvas.TextWidth(Remaining);
x := R.right - WidthOfText - 4;
Canvas.TextOut(x,2, Remaining);
end;
procedure TDBEditWithLenghtCountdown.WndProc(var Message: TMessage);
begin
inherited WndProc(Message);
with Message do
case Msg of
CM_MOUSEENTER, CM_MOUSELEAVE, WM_LBUTTONUP, WM_LBUTTONDOWN,
WM_KEYDOWN, WM_KEYUP,
WM_SETFOCUS, WM_KILLFOCUS,
CM_FONTCHANGED, CM_TEXTCHANGED:
begin
Invalidate;
end;
end; // case
end;
end.

Answer 1

You can test how it would look like without any text interference by setting the edit margins to leave space for the tip text. A quick test:
type
TDBEditWithLenghtCountdown = class(TDBEdit)
..
protected
procedure CreateWnd; override;
property Canvas: TCanvas read FCanvas;
..
procedure TDBEditWithLenghtCountdown.CreateWnd;
var
MaxWidth, Margins: Integer;
begin
inherited;
MaxWidth := Canvas.TextWidth('WW');
Margins := Perform(EM_GETMARGINS, 0, 0);
Margins := MakeLong(HiWord(Margins), LoWord(Margins) + MaxWidth);
Perform(EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN, Margins);
end;
Beyond this is personal opinion but I find this a bit confusing. What I would do is probably publish a status panel field on the derived edit, and output some text to it if it is assigned when the text of the edit control changes.
edit: Here's a somewhat extended version that should take care of the issue mentioned in the comment (if navigate left with a long text, edit text overwrites tip text), and also sets margins only if the control has focus. (Not full code duplicated from the question, only modified bits.)
type
TDBEditWithLenghtCountdown = class(TDBEdit)
private
FCanvas: TCanvas;
FTipWidth: Integer;
FDefMargins: Integer;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
protected
..
procedure TDBEditWithLenghtCountdown.WMPaint(var Message: TWMPaint);
var
PaintStruct: TPaintStruct;
EndPaint: Boolean;
Rgn: HRGN;
R, TipR: TRect;
Remaining : string;
begin
if not Focused then
inherited
else begin
EndPaint := Message.Dc = 0;
if Message.DC = 0 then
Message.DC := BeginPaint(Handle, PaintStruct);
R := ClientRect;
TipR := R;
TipR.Left := TipR.Right - FTipWidth;
Remaining := IntToStr(CharactersRemaining);
Canvas.Handle := Message.DC;
SetBkColor(Canvas.Handle, ColorToRGB(Color));
Canvas.Font := Font;
Canvas.Font.Color := clRed;
Canvas.TextRect(TipR, Remaining, [tfSingleLine, tfCenter, tfVerticalCenter]);
R.Right := TipR.Left;
Rgn := CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom);
SelectClipRgn(Canvas.Handle, Rgn);
DeleteObject(Rgn);
inherited;
if EndPaint then
windows.EndPaint(Handle, PaintStruct);
end;
end;
procedure TDBEditWithLenghtCountdown.WndProc(var Message: TMessage);
const
TipMargin = 3;
begin
inherited WndProc(Message);
with Message do
case Msg of
CM_MOUSEENTER, CM_MOUSELEAVE, WM_LBUTTONUP, WM_LBUTTONDOWN,
WM_KEYDOWN, WM_KEYUP,
CM_TEXTCHANGED: Invalidate;
WM_CREATE: FDefMargins := Perform(EM_GETMARGINS, 0, 0);
CM_FONTCHANGED:
begin
Canvas.Handle := 0;
Canvas.Font := Font;
FTipWidth := Canvas.TextWidth('67') + 2 * TipMargin;
end;
WM_SETFOCUS:
Perform(EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN,
MakeLong(HiWord(FDefMargins), LoWord(FDefMargins) + FTipWidth));
WM_KILLFOCUS:
Perform(EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN, FDefMargins);
end;
end;

Answer 2

Just as a base for you to start with, if do not want to derive every Edit-Component, here is a general approach for every Component derived from TCustomEdit.
Set the MaxLength of the Edit-Component to a Value > 0 and this Unit will paint you a thin red line below the text as a fill indicator.
The Unit has only to be present in your Project.
unit ControlInfoHandler;
interface
uses
Vcl.Forms;
implementation
uses
System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.StdCtrls;
type
TControlInfoHandler = class( TComponent )
private
FCurrent : TWinControl;
FCurrentLength : Integer;
protected
procedure ActiveControlChange( Sender : TObject );
procedure ApplicationIdle( Sender : TObject; var Done : Boolean );
procedure Notification( AComponent : TComponent; Operation : TOperation ); override;
end;
THackedEdit = class( TCustomEdit )
published
property MaxLength;
end;
var
LControlInfoHandler : TControlInfoHandler;
{ TControlInfoHandler }
procedure TControlInfoHandler.ActiveControlChange( Sender : TObject );
begin
FCurrent := Screen.ActiveControl;
FCurrentLength := 0;
if Assigned( FCurrent )
then
FCurrent.FreeNotification( Self );
end;
procedure TControlInfoHandler.ApplicationIdle( Sender : TObject; var Done : Boolean );
var
LEdit : THackedEdit;
LCanvas : TControlCanvas;
LWidth : Integer;
begin
if not Assigned( FCurrent ) or not ( FCurrent is TCustomEdit )
then
Exit;
LEdit := THackedEdit( FCurrent as TCustomEdit );
if ( LEdit.MaxLength > 0 )
then
begin
LCanvas := TControlCanvas.Create;
LCanvas.Control := LEdit;
LCanvas.Pen.Style := psSolid;
LCanvas.Pen.Width := 2;
LWidth := LEdit.Width - 6;
if FCurrentLength <> LEdit.GetTextLen
then
begin
LCanvas.Pen.Color := LEdit.Color;
LCanvas.MoveTo( 0, LEdit.Height - 4 );
LCanvas.LineTo( LWidth, LEdit.Height - 4 );
end;
LCanvas.Pen.Color := clRed;
LWidth := LWidth * LEdit.GetTextLen div LEdit.MaxLength;
LCanvas.MoveTo( 0, LEdit.Height - 4 );
LCanvas.LineTo( LWidth, LEdit.Height - 4 );
FCurrentLength := LEdit.GetTextLen;
end;
end;
procedure TControlInfoHandler.Notification( AComponent : TComponent; Operation : TOperation );
begin
inherited;
if ( FCurrent = AComponent ) and ( Operation = opRemove )
then
FCurrent := nil;
end;
initialization
LControlInfoHandler := TControlInfoHandler.Create( Application );
Screen.OnActiveControlChange := LControlInfoHandler.ActiveControlChange;
Application.OnIdle := LControlInfoHandler.ApplicationIdle;
end.