paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-05 00:37:11 +01:00
Code Issues Packages Projects Releases Wiki Activity

LCL: customedit: rewrite TextHint emulation, use WinAPI if available.

Browse Source 
git-svn-id: trunk@53365 -
This commit is contained in:
ondrej 2016-11-14 14:19:14 +00:00
parent 37928d1126
commit 7ad916287c
11 changed files with 172 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

179
lcl/include/customedit.inc
View File

@ -50,6 +50,10 @@ begin
TWSCustomEditClass(WidgetSetClass).SetCaretPos(Self, fCaretPos);
TWSCustomEditClass(WidgetSetClass).SetSelStart(Self, FSelStart);
TWSCustomEditClass(WidgetSetClass).SetSelLength(Self, FSelLength);
if WidgetSet.GetLCLCapability(lcTextHint) = LCL_CAPABILITY_YES then
TWSCustomEditClass(WidgetSetClass).SetTextHint(Self, FTextHint)
else
if CanShowEmulatedTextHint then ShowEmulatedTextHint;
end;
{------------------------------------------------------------------------------
@ -81,8 +85,6 @@ begin
// Accessibility
AccessibleRole := larTextEditorSingleline;
FTextHint := '';
FTextHintFontColor := clGrayText;
FTextHintFontStyle := [fsItalic];
end;
{------------------------------------------------------------------------------
@ -114,12 +116,6 @@ begin
Result := FTextHint;
end;
procedure TCustomEdit.Loaded;
begin
inherited Loaded;
if CanShowTextHint then ShowTextHint;
end;
{------------------------------------------------------------------------------
Setter for CaretPos
@ -367,21 +363,8 @@ begin
FModified := Value;
end;
function TCustomEdit.GetPasswordChar: Char;
begin
if FTextHintShowing then
Result := FSavedPasswordChar
else
Result := FPasswordChar;
end;
procedure TCustomEdit.SetPasswordChar(const AValue: Char);
begin
if FTextHintShowing and (not FSettingTextHint) and (FSavedPasswordChar<>AValue) then
begin
FSavedPasswordChar := AValue;
Exit;
end;
if FPasswordChar=AValue then exit;
FPasswordChar:=AValue;
@ -391,7 +374,7 @@ begin
else
EchoMode:=emPassword;
end;
if HandleAllocated then
if HandleAllocated and (FEmulatedTextHintStatus=thsHidden) then
TWSCustomEditClass(WidgetSetClass).SetPasswordChar(Self, AValue);
end;
@ -405,14 +388,21 @@ begin
RegisterPropertyToSkip(TCustomEdit, 'OEMConvert', 'VCL compatibility property', '');
end;
function TCustomEdit.CanShowTextHint: Boolean;
function TCustomEdit.CanShowEmulatedTextHint: Boolean;
begin
Result := (([csDesigning,csLoading] * ComponentState) = []) and
Result := HandleAllocated and
(WidgetSet.GetLCLCapability(lcTextHint)=LCL_CAPABILITY_NO) and
(([csDesigning,csLoading] * ComponentState) = []) and
(FTextHint <> '') and
(Text = '') and
(not Focused);
end;
function TCustomEdit.CreateEmulatedTextHintFont: TFont;
begin
Result := TWSCustomEditClass(WidgetSetClass).CreateEmulatedTextHintFont(Self);
end;
{------------------------------------------------------------------------------
Method: TCustomEdit.SetEchoMode
Params: Value to set FModified to
@ -509,6 +499,12 @@ begin
inherited WMChar(Message);
end;
procedure TCustomEdit.WndProc(var Message: TLMessage);
begin
if not((Message.msg=CM_TEXTCHANGED) and (FEmulatedTextHintStatus<>thsHidden)) then //eat CM_TEXTCHANGED
inherited WndProc(Message);
end;
procedure TCustomEdit.CMWantSpecialKey(var Message: TCMWantSpecialKey);
begin
// don't allow LCL to handle arrow keys for edit controls
@ -534,19 +530,24 @@ end;
procedure TCustomEdit.RealSetText(const AValue: TCaption);
begin
if (FEmulatedTextHintStatus=thsShowing) and (AValue<>'') then
HideEmulatedTextHint;
FTextChangedByRealSetText := True;
if FTextHintShowing and (not FSettingTextHint) then HideTextHint;
Modified := False;
inherited RealSetText(AValue);
FTextChangedByRealSetText := False;
if (FEmulatedTextHintStatus=thsHidden) and CanShowEmulatedTextHint then
ShowEmulatedTextHint;
end;
function TCustomEdit.RealGetText: TCaption;
begin
if not FTextHintShowing then
Result := inherited RealGetText
if FEmulatedTextHintStatus=thsShowing then
Result := ''
else
Result := '';
Result := inherited RealGetText;
end;
{------------------------------------------------------------------------------
@ -561,7 +562,6 @@ var
SStart, SLen: Integer;
begin
//debugln('TCustomEdit.TextChanged ',DbgSName(Self));
if FSettingTextHint then Exit;
if FCharCase in [ecUppercase, ecLowercase] then
begin
// use a local variable to reduce amounts of widgetset calls
@ -591,16 +591,6 @@ begin
Change;
end;
end;
if FTextHintShowing then
begin
if not FSettingTextHint and not CanShowTextHint then
HideTextHint;
end
else
begin
if CanShowTextHint then
ShowTextHint;
end;
end;
procedure TCustomEdit.Change;
@ -611,6 +601,7 @@ end;
procedure TCustomEdit.DoEnter;
begin
if FEmulatedTextHintStatus=thsShowing then HideEmulatedTextHint;
//AutoSelect when DoEnter is fired by keyboard
if (FAutoSelect and not (csLButtonDown in ControlState)) then
begin
@ -618,14 +609,30 @@ begin
if (SelText = Text) then FAutoSelected := True;
end;//End if FAutoSelect
inherited DoEnter;
if FTextHintShowing then HideTextHint;
end;
procedure TCustomEdit.DoExit;
begin
FAutoSelected := False;
inherited DoExit;
if CanShowTextHint then ShowTextHint;
if CanShowEmulatedTextHint then ShowEmulatedTextHint;
end;
procedure TCustomEdit.FontChanged(Sender: TObject);
var
HintFont: TObject;
begin
if (FEmulatedTextHintStatus=thsHidden) then
inherited FontChanged(Sender)
else
begin
HintFont := CreateEmulatedTextHintFont;
try
inherited FontChanged(HintFont);
finally
HintFont.Free;
end;
end;
end;
{------------------------------------------------------------------------------
@ -649,71 +656,75 @@ procedure TCustomEdit.SetTextHint(const AValue: TTranslateString);
begin
if (FTextHint = AValue) then Exit;
FTextHint := AValue;
if FTextHintShowing and (FTextHint = '') then
if (WidgetSet.GetLCLCapability(lcTextHint) = LCL_CAPABILITY_YES) and HandleAllocated then
TWSCustomEditClass(WidgetSetClass).SetTextHint(Self, AValue);
if (FEmulatedTextHintStatus=thsShowing) and (FTextHint = '') then
begin
HideTextHint;
HideEmulatedTextHint;
end
else
begin
if CanShowTextHint then ShowTextHint;
if CanShowEmulatedTextHint then ShowEmulatedTextHint;
end;
end;
procedure TCustomEdit.ShowTextHint;
var
OldModified: Boolean;
procedure TCustomEdit.SetTextHintFontColor(const aTextHintFontColor: TColor);
begin
if not FTextHintShowing then
begin
FSavedFontColor := Font.Color;
FSavedFontStyle := Font.Style;
FSavedParentFont := ParentFont;
FSavedPasswordChar := PasswordChar;
end;
FTextHintShowing := True;
OldModified := Modified;
FSettingTextHint := True;
DebugLn('TCustomEdit.TextHintFontColor is deprecated and will be removed in Lazarus 1.9');
end;
procedure TCustomEdit.SetTextHintFontStyle(const aTextHintFontStyle: TFontStyles
);
begin
DebugLn('TCustomEdit.TextHintFontStyle is deprecated and will be removed in Lazarus 1.9');
end;
procedure TCustomEdit.ShowEmulatedTextHint;
var
HintFont: TFont;
begin
if (FEmulatedTextHintStatus<>thsHidden) then
Exit;
FEmulatedTextHintStatus := thsChanging;
HintFont := CreateEmulatedTextHintFont;
try
//settint Text clears modified flag
inherited RealSetText(FTextHint);
Font.Color := clGrayText; //FTextHintFontColor;
Font.Style := [fsItalic]; //FTextHintFontStyle;
PasswordChar := #0;
TWSCustomEditClass(WidgetSetClass).SetFont(Self, HintFont);
finally
FSettingTextHint := False;
Modified := OldModified;
HintFont.Free;
end;
TWSCustomEditClass(WidgetSetClass).SetText(Self, Self.TextHint);
TWSCustomEditClass(WidgetSetClass).SetPasswordChar(Self, #0);
FEmulatedTextHintStatus := thsShowing;
end;
function TCustomEdit.GetTextHintFontColor: TColor;
begin
Result := clGrayText;
Result := clNone;
DebugLn('TCustomEdit.TextHintFontColor is deprecated and will be removed in Lazarus 1.9');
end;
function TCustomEdit.GetTextHintFontStyle: TFontStyles;
begin
Result := [fsItalic];
Result := [];
DebugLn('TCustomEdit.TextHintFontStyle is deprecated and will be removed in Lazarus 1.9');
end;
procedure TCustomEdit.HideTextHint;
var
OldModified: Boolean;
procedure TCustomEdit.HideEmulatedTextHint;
begin
try
//settint Text clears modified flag
OldModified := Modified;
Font.Color := FSavedFontColor;
Font.Style := FSavedFontStyle;
ParentFont := FSavedParentFont;
PasswordChar := FSavedPasswordChar;
FTextHintShowing := False;
FSettingTextHint := True;
inherited RealSetText('');
FTextHintShowing := False;
finally
FSettingTextHint := False;
Modified := OldModified;
end;
if FEmulatedTextHintStatus<>thsShowing then
Exit;
FEmulatedTextHintStatus := thsChanging;
TWSCustomEditClass(WidgetSetClass).SetFont(Self, Font);
TWSCustomEditClass(WidgetSetClass).SetPasswordChar(Self, PasswordChar);
TWSCustomEditClass(WidgetSetClass).SetText(Self, '');
FEmulatedTextHintStatus := thsHidden;
end;
procedure TCustomEdit.SetAlignment(const AValue: TAlignment);

4
lcl/include/custommemo.inc
View File

@ -82,9 +82,9 @@ begin
RegisterCustomMemo;
end;
function TCustomMemo.CanShowTextHint: Boolean;
function TCustomMemo.CanShowEmulatedTextHint: Boolean;
begin
Result := (Lines.Count = 0) and inherited CanShowTextHint;
Result := (Lines.Count = 0) and inherited CanShowEmulatedTextHint;
end;
procedure TCustomMemo.CreateParams(var Params: TCreateParams);

2
lcl/include/wincontrol.inc
View File

@ -4726,7 +4726,7 @@ procedure TWinControl.FontChanged(Sender: TObject);
begin
if HandleAllocated and ([csLoading, csDestroying] * ComponentState = []) then
begin
TWSWinControlClass(WidgetSetClass).SetFont(Self, Font);
TWSWinControlClass(WidgetSetClass).SetFont(Self, TFont(Sender));
Exclude(FWinControlFlags, wcfFontChanged);
end
else

3
lcl/interfacebase.pp
View File

@ -81,7 +81,8 @@ type
lcEmulatedMDI, // used for emulating MDI on widgetsets which does not provide native MDI handling
lcAccessibilitySupport, // Indicates that accessibility is implemented, mostly for TCustomControl descendents as native widgests should have in-built accessibility
lcRadialGradientBrush, // Indicates that the function CreateBrushWithRadialGradient is supported, i.e. we can create a brush with a radial gradient pattern
lcTransparentWindow // ability to pass mouse messages through a window (on win32 LM_NCHITTEST with HTTRANSPARENT result)
lcTransparentWindow, // ability to pass mouse messages through a window (on win32 LM_NCHITTEST with HTTRANSPARENT result)
lcTextHint // native TextHint support
);
{ TDialogButton }

4
lcl/interfaces/qt/qtwscontrols.pp
View File

@ -92,6 +92,8 @@ type
class procedure ScrollBy(const AWinControl: TWinControl; DeltaX, DeltaY: integer); override;
end;
TAccessWinControl = class(TWinControl);
{ TQtWSGraphicControl }
TQtWSGraphicControl = class(TWSGraphicControl)
@ -622,7 +624,7 @@ begin
// issue #28437
if AWinControl.HandleObjectShouldBeVisible and not AWinControl.IsParentFont and
(AWinControl.Font.Name = 'default') then
SetFont(AWinControl, AWinControl.Font);
TAccessWinControl(AWinControl).FontChanged(AWinControl.Font);
Widget.setVisible(AWinControl.HandleObjectShouldBeVisible);
Widget.EndUpdate;

15
lcl/interfaces/win32/win32callback.inc
View File

@ -314,6 +314,8 @@ end;
// The original function was about 2400 lines.
type
TAccessCustomEdit = class(TCustomEdit);
TWindowProcHelper = class
private
// WindowProc parameters
@ -1318,6 +1320,7 @@ var
WindowDC: HDC;
WindowColor: TColor;
ChildWinControl: TWinControl;
EditFont: TFont;
begin
WindowDC := HDC(WParam);
ChildWinControl := ChildWindowInfo^.WinControl;
@ -1346,7 +1349,17 @@ begin
begin
if ChildWinControl <> nil then
begin
WindowColor := ChildWinControl.Font.Color;
if (ChildWinControl is TCustomEdit)
and (TAccessCustomEdit(ChildWinControl).FEmulatedTextHintStatus=thsShowing) then
begin
EditFont := TAccessCustomEdit(ChildWinControl).CreateEmulatedTextHintFont;
try
WindowColor := EditFont.Color;
finally
EditFont.Free;
end;
end else
WindowColor := ChildWinControl.Font.Color;
if WindowColor = clDefault then
WindowColor := ChildWinControl.GetDefaultColor(dctFont);
Windows.SetTextColor(WindowDC, ColorToRGB(WindowColor));

7
lcl/interfaces/win32/win32object.inc
View File

@ -564,6 +564,13 @@ begin
lcNeedMininimizeAppWithMainForm: Result := LCL_CAPABILITY_NO;
lcSendsUTF8KeyPress: Result := LCL_CAPABILITY_YES;
lcTransparentWindow: Result := LCL_CAPABILITY_YES;
lcTextHint:
begin
if (ComCtlVersion >= ComCtlVersionIE6) then
Result := LCL_CAPABILITY_YES
else
Result := LCL_CAPABILITY_NO;
end;
else
Result := inherited;
end;

8
lcl/interfaces/win32/win32wsstdctrls.pp
View File

@ -177,6 +177,7 @@ type
class procedure SetSelLength(const ACustomEdit: TCustomEdit; NewLength: integer); override;
class procedure SetText(const AWinControl: TWinControl; const AText: string); override;
class procedure SetFont(const AWinControl: TWinControl; const AFont: TFont); override;
class procedure SetTextHint(const ACustomEdit: TCustomEdit; const ATextHint: string); override;
class procedure Cut(const ACustomEdit: TCustomEdit); override;
class procedure Copy(const ACustomEdit: TCustomEdit); override;
@ -1308,6 +1309,13 @@ begin
TWin32WSWinControl.SetText(ACustomEdit, AText);
end;
class procedure TWin32WSCustomEdit.SetTextHint(const ACustomEdit: TCustomEdit;
const ATextHint: string);
begin
if not WSCheckHandleAllocated(ACustomEdit, 'SetTextHint') then Exit;
SendMessage(ACustomEdit.Handle, EM_SETCUEBANNER, 1, {%H-}LParam(PWideChar(WideString(ATextHint))));
end;
class procedure TWin32WSCustomEdit.Cut(const ACustomEdit: TCustomEdit);
begin
SendMessage(ACustomEdit.Handle, WM_CUT, 0, 0)

6
lcl/maskedit.pp
View File

@ -220,7 +220,7 @@ const
procedure DeleteChars(NextChar : Boolean);
protected
function ApplyMaskToText(Value: TCaption): TCaption;
function CanShowTextHint: Boolean; override;
function CanShowEmulatedTextHint: Boolean; override;
function DisableMask(const NewText: String): Boolean;
function RestoreMask(const NewText: String): Boolean;
procedure RealSetText(const AValue: TCaption); override;
@ -1521,12 +1521,12 @@ begin
Result := S;
end;
function TCustomMaskEdit.CanShowTextHint: Boolean;
function TCustomMaskEdit.CanShowEmulatedTextHint: Boolean;
begin
if IsMasked then
Result := False
else
Result := inherited CanShowTextHint;
Result := inherited CanShowEmulatedTextHint;
end;

33
lcl/stdctrls.pp
View File

@ -709,18 +709,10 @@ type
FSelStart: integer;
FTextChangedByRealSetText: Boolean;
FTextHint: TTranslateString;
FTextHintShowing: Boolean;
FSettingTextHint: Boolean;
FTextHintFontColor: TColor; //Remove in 1.9
FTextHintFontStyle: TFontStyles; //Remove in 1.9
FSavedFontColor: TColor;
FSavedFontStyle: TFontStyles;
FSavedParentFont: Boolean;
FSavedPasswordChar: Char;
function GetTextHintFontColor: TColor; //Remove in 1.9
function GetTextHintFontStyle: TFontStyles; //Remove in 1.9
procedure ShowTextHint;
procedure HideTextHint;
procedure ShowEmulatedTextHint;
procedure HideEmulatedTextHint;
procedure SetAlignment(const AValue: TAlignment);
function GetCanUndo: Boolean;
function GetModified: Boolean;
@ -728,16 +720,23 @@ type
procedure SetHideSelection(const AValue: Boolean);
procedure SetMaxLength(Value: Integer);
procedure SetModified(Value: Boolean);
function GetPasswordChar: Char;
procedure SetPasswordChar(const AValue: Char);
procedure SetTextHintFontColor(const aTextHintFontColor: TColor);
procedure SetTextHintFontStyle(const aTextHintFontStyle: TFontStyles);
protected type
TEmulatedTextHintStatus = (thsHidden, thsShowing, thsChanging);
protected
FEmulatedTextHintStatus: TEmulatedTextHintStatus;
class procedure WSRegisterClass; override;
function CanShowTextHint: Boolean; virtual;
function CanShowEmulatedTextHint: Boolean; virtual;
function CreateEmulatedTextHintFont: TFont; virtual;
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
WithThemeSpace: Boolean); override;
procedure CreateParams(var Params: TCreateParams); override;
procedure InitializeWnd; override;
procedure TextChanged; override;
procedure FontChanged(Sender: TObject); override;
procedure Change; virtual;
procedure DoEnter; override;
procedure DoExit; override;
@ -748,7 +747,6 @@ type
function GetSelStart: integer; virtual;
function GetSelText: string; virtual;
function GetTextHint: TTranslateString; virtual;
procedure Loaded; override;
procedure SetCaretPos(const Value: TPoint); virtual;
procedure SetEchoMode(Val: TEchoMode); virtual;
procedure SetNumbersOnly(Value: Boolean); virtual;
@ -765,6 +763,7 @@ type
procedure KeyUpAfterInterface(var Key: Word; Shift: TShiftState); override;
procedure WMChar(var Message: TLMChar); message LM_CHAR;
procedure CMWantSpecialKey(var Message: TCMWantSpecialKey); message CM_WANTSPECIALKEY;
procedure WndProc(var Message: TLMessage); override;
property AutoSelect: Boolean read FAutoSelect write FAutoSelect default True;
property AutoSelected: Boolean read FAutoSelected write FAutoSelected;
@ -791,7 +790,7 @@ type
property Modified: Boolean read GetModified write SetModified;
property NumbersOnly: Boolean read GetNumbersOnly write SetNumbersOnly default false;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property PasswordChar: Char read GetPasswordChar write SetPasswordChar default #0;
property PasswordChar: Char read FPasswordChar write SetPasswordChar default #0;
property PopupMenu;
property ReadOnly: Boolean read GetReadOnly write SetReadOnly default false;
property SelLength: integer read GetSelLength write SetSelLength;
@ -801,8 +800,8 @@ type
property TabStop default true;
property Text;
property TextHint: TTranslateString read GetTextHint write SetTextHint;
property TextHintFontColor: TColor read GetTextHintFontColor write FTextHintFontColor default clGrayText; deprecated 'Will be removed in the future'; //deprecated in 1.7
property TextHintFontStyle: TFontStyles read GetTextHintFontStyle write FTextHintFontStyle default [fsItalic]; deprecated 'Will be removed in the future';
property TextHintFontColor: TColor read GetTextHintFontColor write SetTextHintFontColor default clGrayText; deprecated 'Will be removed in the future'; //deprecated in 1.7
property TextHintFontStyle: TFontStyles read GetTextHintFontStyle write SetTextHintFontStyle default [fsItalic]; deprecated 'Will be removed in the future';
end;
@ -838,7 +837,6 @@ type
procedure SetVertScrollBar(const AValue: TMemoScrollBar);
protected
class procedure WSRegisterClass; override;
function CanShowTextHint: Boolean; override;
procedure CreateParams(var Params: TCreateParams); override;
procedure InitializeWnd; override;
procedure FinalizeWnd; override;
@ -859,6 +857,7 @@ type
procedure WMGetDlgCode(var Message: TLMNoParams); message LM_GETDLGCODE;
class function GetControlClassDefaultSize: TSize; override;
procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
function CanShowEmulatedTextHint: Boolean; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;

21
lcl/widgetset/wsstdctrls.pp
View File

@ -159,6 +159,8 @@ type
class procedure SetReadOnly(const ACustomEdit: TCustomEdit; NewReadOnly: boolean); virtual;
class procedure SetSelStart(const ACustomEdit: TCustomEdit; NewStart: integer); virtual;
class procedure SetSelLength(const ACustomEdit: TCustomEdit; NewLength: integer); virtual;
class procedure SetTextHint(const ACustomEdit: TCustomEdit; const ATextHint: string); virtual;
class function CreateEmulatedTextHintFont(const ACustomEdit: TCustomEdit): TFont; virtual;
class procedure Cut(const ACustomEdit: TCustomEdit); virtual;
class procedure Copy(const ACustomEdit: TCustomEdit); virtual;
@ -564,6 +566,11 @@ class procedure TWSCustomEdit.SetSelStart(const ACustomEdit: TCustomEdit; NewSta
begin
end;
class procedure TWSCustomEdit.SetTextHint(const ACustomEdit: TCustomEdit;
const ATextHint: string);
begin
end;
class procedure TWSCustomEdit.SetSelLength(const ACustomEdit: TCustomEdit; NewLength: integer);
begin
end;
@ -580,6 +587,20 @@ begin
Clipboard.AsText := ACustomEdit.SelText;
end;
class function TWSCustomEdit.CreateEmulatedTextHintFont(
const ACustomEdit: TCustomEdit): TFont;
begin
Result := TFont.Create;
try
Result.Assign(ACustomEdit.Font);
Result.Color := clGrayText;
except
Result.Free;
Result := nil;
raise;
end;
end;
class procedure TWSCustomEdit.Paste(const ACustomEdit: TCustomEdit);
begin
if Clipboard.HasFormat(CF_TEXT) then