- revert 33020 #928292514b, 33082 #dd109fba91, 33086 #bd7b46c17a, part of 33089 and 33389. These changes made the hint behavior Delphi incompatible thus leading to a regression in third party control like VirtualTreeView that handles hints in CMHintShow
- Retrieve parent hint recursively if hintcontrol.hint is empty' (delphi compatible)
- Added sample project to test hints

git-svn-id: trunk@38802 -
This commit is contained in:
blikblum 2012-09-23 23:06:31 +00:00
parent dde19a64cc
commit 40f8498835
9 changed files with 513 additions and 35 deletions

5
.gitattributes vendored
View File

@ -3926,6 +3926,11 @@ examples/componentstreaming/componentstreaming.lpi svneol=native#text/plain
examples/componentstreaming/componentstreaming.lpr svneol=native#text/plain
examples/componentstreaming/mainunit.lfm svneol=native#text/plain
examples/componentstreaming/mainunit.pas svneol=native#text/plain
examples/controlhint/Project1.lpi svneol=native#text/plain
examples/controlhint/Project1.lpr svneol=native#text/plain
examples/controlhint/Project1.res -text
examples/controlhint/Unit1.lfm svneol=native#text/plain
examples/controlhint/Unit1.pas svneol=native#text/plain
examples/cursors/car.cur -text svneol=unset#image/x-cursor
examples/cursors/car.lrs svneol=native#text/pascal
examples/cursors/project1.lpi svneol=native#text/plain

View File

@ -0,0 +1,96 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<Flags>
<MainUnitHasUsesSectionForAllUnits Value="False"/>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="Project1"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="Project1.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="Unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<SyntaxMode Value="Delphi"/>
</SyntaxOptions>
</Parsing>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

View File

@ -0,0 +1,15 @@
program Project1;
{$MODE Delphi}
uses
Forms, Interfaces,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

Binary file not shown.

View File

@ -0,0 +1,164 @@
object Form1: TForm1
Left = 285
Height = 666
Hint = 'Form'
Top = 111
Width = 870
Caption = 'Test Control Hint'
ClientHeight = 666
ClientWidth = 870
Color = clBtnFace
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
OnCreate = FormCreate
LCLVersion = '1.1'
object ListBox1: TListBox
Left = 472
Height = 569
Top = 8
Width = 353
ItemHeight = 0
TabOrder = 0
end
object ButtonClear: TButton
Left = 752
Height = 25
Top = 584
Width = 75
Caption = 'Clear'
OnClick = ButtonClearClick
TabOrder = 1
end
object GroupBoxNoShowHint: TGroupBox
Left = 8
Height = 177
Hint = 'GroupBox'
Top = 192
Width = 449
Caption = 'ShowHint = False'
ClientHeight = 159
ClientWidth = 445
TabOrder = 2
object ButtonShowHintNoParent1: TButton
Left = 14
Height = 25
Hint = 'Button'
Top = 26
Width = 209
Caption = 'ShowHint = True Parent = False'
ParentShowHint = False
ShowHint = True
TabOrder = 0
end
object Button1: TButton
Left = 14
Height = 25
Hint = 'Button'
Top = 74
Width = 209
Caption = 'ShowHint = False Parent = False'
ParentShowHint = False
TabOrder = 1
end
object Button2: TButton
Left = 230
Height = 25
Top = 26
Width = 209
Caption = 'ShowHint = True Parent = True'
Enabled = False
TabOrder = 2
end
object ButtonNoShowHintShowParent: TButton
Left = 230
Height = 25
Hint = 'Button'
Top = 74
Width = 209
Caption = 'ShowHint = False Parent = True'
TabOrder = 3
end
object Button8: TButton
Left = 78
Height = 25
Top = 115
Width = 296
Caption = 'ShowHint = True Parent = False / Hint = '''''
ParentShowHint = False
ShowHint = True
TabOrder = 4
end
end
object GroupBoxShowHint: TGroupBox
Left = 8
Height = 217
Hint = 'GroupBox'
Top = 392
Width = 449
Caption = 'ShowHint = True'
ClientHeight = 199
ClientWidth = 445
ParentShowHint = False
ShowHint = True
TabOrder = 3
object Button3: TButton
Left = 14
Height = 25
Hint = 'Button'
Top = 26
Width = 209
Caption = 'ShowHint = True Parent = False'
ParentShowHint = False
ShowHint = True
TabOrder = 0
end
object Button4: TButton
Left = 14
Height = 25
Hint = 'Button'
Top = 74
Width = 209
Caption = 'ShowHint = False Parent = False'
ParentShowHint = False
TabOrder = 1
end
object Button5: TButton
Left = 230
Height = 25
Hint = 'Button'
Top = 26
Width = 209
Caption = 'ShowHint = True Parent = True'
TabOrder = 2
end
object Button6: TButton
Left = 230
Height = 25
Hint = 'Button'
Top = 74
Width = 209
Caption = 'ShowHint = False Parent = True'
Enabled = False
ParentShowHint = False
TabOrder = 3
end
object Button7: TButton
Left = 78
Height = 25
Top = 123
Width = 296
Caption = 'ShowHint = True Parent = True / Hint = '''''
TabOrder = 4
end
end
object CheckBox1: TCheckBox
Left = 8
Height = 19
Top = 160
Width = 146
Caption = 'GroupBox With Empty Hint'
OnChange = CheckBox1Change
TabOrder = 4
end
end

View File

@ -0,0 +1,221 @@
unit Unit1;
{$MODE Delphi}
interface
uses
LCLIntf, LCLType, LMessages, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TOnHintEvent = procedure(Sender: TObject; HintInfo: PHintInfo) of object;
TMyHintControl = class (TCustomControl)
private
FBlueRect, FRedRect, FWhiteRect, FYellowRect: TRect;
FOnHintEvent: TOnHintEvent;
FShowOnlyRed: Boolean;
procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
procedure SetOnHintEvent(const Value: TOnHintEvent);
procedure SetShowOnlyRed(const Value: Boolean);
protected
procedure Resize; override;
public
constructor Create(TheOwner: TComponent); override;
procedure Paint; override;
property ShowOnlyRed: Boolean read FShowOnlyRed write SetShowOnlyRed;
property OnHintEvent: TOnHintEvent read FOnHintEvent write SetOnHintEvent;
end;
TMyHintButton = class (TButton)
private
procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
protected
public
end;
{ TForm1 }
TForm1 = class(TForm)
Button7: TButton;
Button8: TButton;
CheckBox1: TCheckBox;
ListBox1: TListBox;
ButtonClear: TButton;
GroupBoxNoShowHint: TGroupBox;
ButtonShowHintNoParent1: TButton;
Button1: TButton;
Button2: TButton;
ButtonNoShowHintShowParent: TButton;
GroupBoxShowHint: TGroupBox;
Button3: TButton;
Button4: TButton;
Button5: TButton;
Button6: TButton;
procedure CheckBox1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ButtonClearClick(Sender: TObject);
private
{ Private declarations }
FMyHintControl,FMyHintControl2 : TMyHintControl;
FMyHintButton: TMyHintButton;
procedure HintEvent(Sender: TObject; HintInfo: PHintInfo);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TMyHintControl }
procedure TMyHintControl.CMHintShow(var Message: TMessage);
begin
with TCMHintShow(Message), HintInfo^ do
begin
if Assigned(FOnHintEvent) then
FOnHintEvent(Self, HintInfo);
Result := 1;
if PtInRect(FRedRect, CursorPos) then
begin
Result := 0;
HintStr := 'Red' + #13#10 + 'aaaaa_bbbbb_ccccc_dddddd_eeeeee';
CursorRect := FRedRect;
end;
if FShowOnlyRed then
Exit;
if PtInRect(FBlueRect, CursorPos) then
begin
Result := 0;
HintStr := 'Blue';
CursorRect := FBlueRect;
end;
if PtInRect(FYellowRect, CursorPos) then
begin
Result := 0;
HintStr := 'Yellow';
CursorRect := FYellowRect;
end;
if PtInRect(FWhiteRect, CursorPos) then
begin
Result := 0;
HintStr := 'White';
CursorRect := FWhiteRect;
end;
end;
end;
constructor TMyHintControl.Create(TheOwner: TComponent);
begin
inherited;
Hint := 'Control Hint';
ShowHint := True;
end;
procedure TMyHintControl.Paint;
begin
with Canvas do
begin
Brush.Color := clRed;
FillRect(FRedRect);
Brush.Color := clWhite;
FillRect(FWhiteRect);
Brush.Color := clBlue;
FillRect(FBlueRect);
Brush.Color := clYellow;
FillRect(FYellowRect);
end;
end;
procedure TMyHintButton.CMHintShow(var Message: TMessage);
begin
TCMHintShow(Message).HintInfo^.HintStr := 'CMHintShow';
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FMyHintControl := TMyHintControl.Create(Self);
with FMyHintControl do
begin
ShowOnlyRed := True;
OnHintEvent := HintEvent;
Parent := Self;
SetBounds(10, 10, 100, 100);
Visible := True;
end;
FMyHintControl2 := TMyHintControl.Create(Self);
with FMyHintControl2 do
begin
OnHintEvent := HintEvent;
Parent := Self;
SetBounds(120, 10, 100, 100);
Visible := True;
end;
FMyHintButton := TMyHintButton.Create(Self);
FMyHintButton.Parent := GroupBoxShowHint;
FMyHintButton.Left := Button7.Left;
FMyHintButton.Width := Button7.Width;
FMyHintButton.Top := Button7.Top + 36;
FMyHintButton.ParentShowHint := True;
FMyHintButton.ShowHint := True;
FMyHintButton.Caption := 'ShowHint = True Parent = True / Hint = '''' / CMHintShow';
end;
procedure TForm1.CheckBox1Change(Sender: TObject);
begin
if CheckBox1.Checked then
begin
GroupBoxNoShowHint.Hint := '';
GroupBoxShowHint.Hint := '';
end
else
begin
GroupBoxNoShowHint.Hint := 'GroupBox';
GroupBoxShowHint.Hint := 'GroupBox';
end;
end;
procedure TMyHintControl.Resize;
begin
inherited;
FRedRect := Rect(0, 0, Width div 2, Height div 2);
FWhiteRect := Rect(Width div 2, 0, Width, Height div 2);
FBlueRect := Rect(0, Height div 2, Width div 2, Height);
FYellowRect := Rect(Width div 2, Height div 2, Width, Height);
end;
procedure TMyHintControl.SetOnHintEvent(const Value: TOnHintEvent);
begin
FOnHintEvent := Value;
end;
procedure TForm1.HintEvent(Sender: TObject; HintInfo: PHintInfo);
begin
with HintInfo^ do
begin
ListBox1.Items.Add(Format('CursorPoint X: %d Y: %d', [CursorPos.X, CursorPos.Y]));
ListBox1.Items.Add(Format('CursorRect L: %d T: %d R: %d B: %d',
[CursorRect.Left, CursorRect.Top, CursorRect.Right, CursorRect.Bottom]));
end;
end;
procedure TForm1.ButtonClearClick(Sender: TObject);
begin
ListBox1.Clear;
end;
procedure TMyHintControl.SetShowOnlyRed(const Value: Boolean);
begin
FShowOnlyRed := Value;
end;
end.

View File

@ -1499,7 +1499,6 @@ type
function IsEnabled: Boolean; // checks parent too
function IsParentColor: Boolean; // checks protected ParentColor, needed by widgetsets
function IsParentFont: Boolean; // checks protected ParentFont, needed by widgetsets
function IsParentShowHint: Boolean; // checks protected ParentShowHint prop.
function FormIsUpdating: boolean; virtual;
function IsProcessingPaintMsg: boolean;
procedure Hide;

View File

@ -36,28 +36,22 @@ begin
//debugln('FindApplicationComponent ComponentName="',ComponentName,'" Result=',DbgSName(Result));
end;
function GetHintControl(Control: TControl): TControl;
// Returns control that provides hint text for the specified Control, or nil if no hint.
// If Hint='' and ParentShowHint=True, hint text comes from the closest parent that has it.
function GetControlShortHint(Control: TControl): String;
begin
// The control or one of its parents must have ShowHint=True.
Result := Control;
while (Result <> nil) and not Result.ShowHint do begin
if not Result.IsParentShowHint then // No ShowHint nor ParentShowHint.
exit(nil);
Result := Result.Parent; // A level up in parent tree.
Result := '';
while (Control <> nil) and (Result = '') do
begin
Result := GetShortHint(Control.Hint);
Control := Control.Parent;
end;
if (Result = nil) then // None of parents has ShowHint=True
exit;
end;
// Find control that actually provides the hint = first parent with a hint text.
function GetHintControl(Control: TControl): TControl;
begin
Result := Control;
while (Result <> nil) and (Result.Hint = '') and (Result.OnShowHint = nil)
and (Result.ShowHint or Result.IsParentShowHint) do
while (Result <> nil) and (not Result.ShowHint) do
Result := Result.Parent;
// Show hint only when program is running in normal state
if (Result <> nil) and
if (Result <> nil)and
([csDesigning, csDestroying, csLoading] * Result.ComponentState <> []) then
Result := nil;
end;
@ -814,7 +808,7 @@ begin
OffsetRect(HintInfo.CursorRect, ParentOrigin.X - ClientOrigin.X,
ParentOrigin.Y - ClientOrigin.Y);
HintInfo.CursorPos := FHintControl.ScreenToClient(Info.MousePos);
HintInfo.HintStr := GetShortHint(Info.Control.Hint);
HintInfo.HintStr := GetControlShortHint(Info.Control);
HintInfo.ReshowTimeout := 0;
HintInfo.HideTimeout := FHintHidePause
+FHintHidePausePerChar*length(HintInfo.HintStr);

View File

@ -1001,22 +1001,6 @@ begin
Result := FParentFont;
end;
{------------------------------------------------------------------------------
Method: TControl.IsParentShowHint
Params: none
Returns: Boolean
Used at places where we need to check ParentShowHint from TControl.
Property is protected, so this function avoids hacking to get
protected property value.
Example of usage is GetHintControl()
from application.inc (issue #20518) .
------------------------------------------------------------------------------}
function TControl.IsParentShowHint: Boolean;
begin
Result := FParentShowHint;
end;
function TControl.FormIsUpdating: boolean;
begin
Result := Assigned(Parent) and Parent.FormIsUpdating;