diff --git a/.gitattributes b/.gitattributes index c0f7ace8cb..9a86967127 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/examples/controlhint/Project1.lpi b/examples/controlhint/Project1.lpi new file mode 100644 index 0000000000..8039a262e2 --- /dev/null +++ b/examples/controlhint/Project1.lpi @@ -0,0 +1,96 @@ + + + + + + + + + + + + + + + <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> diff --git a/examples/controlhint/Project1.lpr b/examples/controlhint/Project1.lpr new file mode 100644 index 0000000000..961d5a86ce --- /dev/null +++ b/examples/controlhint/Project1.lpr @@ -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. diff --git a/examples/controlhint/Project1.res b/examples/controlhint/Project1.res new file mode 100644 index 0000000000..e66ecf85fe Binary files /dev/null and b/examples/controlhint/Project1.res differ diff --git a/examples/controlhint/Unit1.lfm b/examples/controlhint/Unit1.lfm new file mode 100644 index 0000000000..4b6294632c --- /dev/null +++ b/examples/controlhint/Unit1.lfm @@ -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 diff --git a/examples/controlhint/Unit1.pas b/examples/controlhint/Unit1.pas new file mode 100644 index 0000000000..c0088c0ecc --- /dev/null +++ b/examples/controlhint/Unit1.pas @@ -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. + diff --git a/lcl/controls.pp b/lcl/controls.pp index 606cf820e5..c79be31387 100644 --- a/lcl/controls.pp +++ b/lcl/controls.pp @@ -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; diff --git a/lcl/include/application.inc b/lcl/include/application.inc index f94896ea56..90cfe16950 100644 --- a/lcl/include/application.inc +++ b/lcl/include/application.inc @@ -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); diff --git a/lcl/include/control.inc b/lcl/include/control.inc index dc812103f9..abef8970bf 100644 --- a/lcl/include/control.inc +++ b/lcl/include/control.inc @@ -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;