summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/corelib/fpgfx.pas73
-rw-r--r--src/corelib/gfx_widget.pas2
-rw-r--r--src/gui/gui_edit.pas7
-rw-r--r--src/gui/gui_hint.pas140
-rw-r--r--src/gui/gui_label.pas8
5 files changed, 150 insertions, 80 deletions
diff --git a/src/corelib/fpgfx.pas b/src/corelib/fpgfx.pas
index 7b777a4a..67f10d2d 100644
--- a/src/corelib/fpgfx.pas
+++ b/src/corelib/fpgfx.pas
@@ -148,8 +148,6 @@ type
end;
- { TfpgCanvas }
-
TfpgCanvas = class(TfpgCanvasImpl)
private
function AddLineBreaks(const s: TfpgString; aMaxLineWidth: integer): string;
@@ -198,14 +196,16 @@ type
end;
- { TfpgApplication }
-
TfpgApplication = class(TfpgApplicationImpl)
private
+ FHintPause: Integer;
FOnException: TExceptionEvent;
FStopOnException: Boolean;
+ FHintWindow: TfpgWindow;
+ procedure SetHintPause(const AValue: Integer);
procedure SetupLocalizationStrings;
procedure InternalMsgClose(var msg: TfpgMessageRec); message FPGM_CLOSE;
+ procedure CreateHintWindow;
protected
FDisplayParams: string;
FScreenWidth: integer;
@@ -221,15 +221,19 @@ type
constructor Create(const AParams: string = ''); override;
destructor Destroy; override;
function GetFont(const afontdesc: string): TfpgFont;
- procedure Initialize;
- procedure Run;
+ procedure ActivateHint(APos: TPoint; AHint: TfpgString);
procedure Flush;
+ procedure HandleException(Sender: TObject);
+ procedure HideHint;
+ procedure Initialize;
procedure ProcessMessages;
+ procedure Run;
procedure SetMessageHook(AWidget: TObject; const AMsgCode: integer; AListener: TObject);
- procedure UnsetMessageHook(AWidget: TObject; const AMsgCode: integer; AListener: TObject);
- procedure HandleException(Sender: TObject);
procedure ShowException(E: Exception);
+ procedure UnsetMessageHook(AWidget: TObject; const AMsgCode: integer; AListener: TObject);
property DefaultFont: TfpgFont read FDefaultFont;
+ property HintPause: Integer read FHintPause write SetHintPause;
+ property HintWindow: TfpgWindow read FHintWindow;
property ScreenWidth: integer read FScreenWidth;
property ScreenHeight: integer read FScreenHeight;
property StopOnException: Boolean read FStopOnException write FStopOnException;
@@ -355,7 +359,8 @@ uses
gfx_translations,
gfx_constants,
gfx_UTF8utils,
- gui_dialogs;
+ gui_dialogs,
+ gui_hint;
var
fpgTimers: TList;
@@ -781,6 +786,8 @@ begin
FScreenHeight := -1;
FMessageHookList := TFPList.Create;
FStopOnException := False;
+ FHintWindow := nil;
+ FHintPause := 1500; // 1.5 seconds
try
inherited Create(AParams);
@@ -803,6 +810,12 @@ var
i: integer;
frm: TfpgWindowBase;
begin
+ if Assigned(FHintWindow) then
+ begin
+ HideHint;
+ FHintWindow.Free;
+ end;
+
DestroyComponents; // while message queue is still active
for i := 0 to (fpgNamedFonts.Count - 1) do
@@ -881,6 +894,23 @@ begin
end;
end;
+procedure TfpgApplication.ActivateHint(APos: TPoint; AHint: TfpgString);
+var
+ wnd: TfpgHintWindow;
+ w: Integer;
+ h: Integer;
+begin
+ wnd := TfpgHintWindow(FHintWindow);
+ if Assigned(wnd) and wnd.Visible then
+ Exit; //==> Nothing to do
+
+ wnd.Text := AHint;
+ w := wnd.Font.TextWidth(AHint) + (wnd.Border * 2) + (wnd.Margin * 2);
+ h := wnd.Font.Height + (wnd.Border * 2) + (wnd.Margin * 2);
+ wnd.SetPosition(APos.X, APos.Y, w, h);
+ wnd.Show;
+end;
+
procedure TfpgApplication.Initialize;
begin
{ TODO : Remember to process parameters!! }
@@ -949,6 +979,11 @@ begin
end;
+procedure TfpgApplication.SetHintPause(const AValue: Integer);
+begin
+ FHintPause := AValue;
+end;
+
procedure TfpgApplication.InternalMsgClose(var msg: TfpgMessageRec);
begin
// writeln('InternalMsgClose received');
@@ -961,6 +996,16 @@ begin
end;
end;
+procedure TfpgApplication.CreateHintWindow;
+begin
+ if not Assigned(FHintWindow) then
+ begin
+ FHintWindow := HintWindowClass.Create(nil);
+ writeln('HintWindow.Classname=', FHintWindow.ClassName);
+ TfpgHintWindow(FHintWindow).Visible := False;
+ end;
+end;
+
procedure TfpgApplication.FreeFontRes(afontres: TfpgFontResource);
var
n: integer;
@@ -986,6 +1031,7 @@ begin
// This will process Application and fpGUI Toolkit translation (*.po) files
TranslateResourceStrings(ApplicationName, ExtractFilePath(ParamStr(0)), '');
SetupLocalizationStrings;
+ CreateHintWindow;
end;
procedure TfpgApplication.Flush;
@@ -1056,6 +1102,15 @@ begin
Terminated := True;
end;
+procedure TfpgApplication.HideHint;
+begin
+ {$IFDEF DEBUG}
+ writeln('HideHint');
+ {$ENDIF}
+ if Assigned(FHintWindow) and TfpgHintWindow(FHintWindow).Visible then
+ TfpgHintWindow(FHintWindow).Hide;
+end;
+
procedure TfpgApplication.ShowException(E: Exception);
begin
TfpgMessageDialog.Critical('An unexpected error occurred.', E.Message);
diff --git a/src/corelib/gfx_widget.pas b/src/corelib/gfx_widget.pas
index dd2df625..a31815de 100644
--- a/src/corelib/gfx_widget.pas
+++ b/src/corelib/gfx_widget.pas
@@ -841,7 +841,7 @@ begin
writeln('TfpgWidget.HandleMouseExit: ' + ClassName);
{$ENDIF}
if FShowHint then
- HideHint;
+ fpgApplication.HideHint;
end;
procedure TfpgWidget.HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint);
diff --git a/src/gui/gui_edit.pas b/src/gui/gui_edit.pas
index 71565fdc..a00e06f0 100644
--- a/src/gui/gui_edit.pas
+++ b/src/gui/gui_edit.pas
@@ -885,7 +885,7 @@ begin
if FHintTimer.Enabled then
FHintTimer.Reset // keep reseting to prevent hint from showing
else
- HideHint;
+ fpgApplication.HideHint;
end;
Exit; //==>
end;
@@ -976,7 +976,7 @@ begin
FDefaultPopupMenu := nil;
FOnChange := nil;
- FHintTimer := TfpgTimer.Create(1500);
+ FHintTimer := TfpgTimer.Create(fpgApplication.HintPause);
FHintTimer.OnTimer := @HintTimerFired;
end;
@@ -1105,7 +1105,8 @@ end;
procedure TfpgBaseEdit.HintTimerFired(Sender: TObject);
begin
- DisplayHint(WindowToScreen(Self, FMousePoint), FHint);
+// Writeln('TfpgBaseEdit.HintTimerFired');
+ fpgApplication.ActivateHint(WindowToScreen(Self, FMousePoint), FHint);
FHintTimer.Enabled := False;
end;
diff --git a/src/gui/gui_hint.pas b/src/gui/gui_hint.pas
index e106f7f3..09db8db5 100644
--- a/src/gui/gui_hint.pas
+++ b/src/gui/gui_hint.pas
@@ -1,3 +1,20 @@
+{
+ fpGUI - Free Pascal GUI Toolkit
+
+ Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this
+ distribution, for details of the copyright.
+
+ See the file COPYING.modifiedLGPL, included in this distribution,
+ for details about redistributing fpGUI.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ Description:
+ Defines a window that gets used to display help hints (aka a HintWindow)
+}
+
unit gui_hint;
{$mode objfpc}{$H+}
@@ -7,14 +24,16 @@ unit gui_hint;
interface
uses
- Classes, SysUtils,
- fpgfx, gfxbase,
- gui_form, gui_label;
+ Classes,
+ SysUtils,
+ fpgfx,
+ gfxbase,
+ gui_form,
+ gui_label;
type
- TF_Hint = class(TfpgForm)
+ TfpgHintWindow = class(TfpgForm)
private
- FText: string;
FFont: TfpgFont;
FTime: Integer;
FShadow: Integer;
@@ -24,6 +43,8 @@ type
T_Chrono: TfpgTimer;
procedure FormShow(Sender: TObject);
procedure FormHide(Sender: TObject);
+ function GetText: TfpgString;
+ procedure SetText(const AValue: TfpgString);
procedure T_ChronoFini(Sender: TObject);
procedure SetShadow(AValue: Integer);
procedure SetBorder(AValue: Integer);
@@ -32,10 +53,12 @@ type
procedure SetLBackgroundColor(AValue: Tfpgcolor);
procedure SetShadowColor(AValue: TfpgColor);
protected
- property Font: TfpgFont read FFont;
+ procedure HandleShow; override;
public
constructor Create(AOwner: TComponent); override;
- property Text: string read FText write FText;
+ procedure SetPosition(aleft, atop, awidth, aheight: TfpgCoord); override;
+ property Font: TfpgFont read FFont;
+ property Text: TfpgString read GetText write SetText;
property Shadow: Integer read FShadow write SetShadow default 5;
property Border: Integer read FBorder write SetBorder default 1;
property Margin: Integer read FMargin write FMargin default 3;
@@ -46,73 +69,50 @@ type
end;
+ TfpgHintWindowClass = class of TfpgHintWindow;
+
+var
+ HintWindowClass: TfpgHintWindowClass = TfpgHintWindow;
+
+
+implementation
+
+type
TF_Shadow = class(TfpgForm)
public
constructor Create(AOwner: TComponent); override;
end;
-
-
+
+
var
- F_Hint: TF_Hint;
F_Shadow: TF_Shadow;
-procedure DisplayHint(Pt: TPoint; AHint: string);
-procedure HideHint;
+{ TfpgHintWindow }
-
-implementation
-
-
-procedure DisplayHint(Pt: TPoint; AHint: string);
+procedure TfpgHintWindow.FormShow(Sender: TObject);
begin
- {$IFDEF DEBUG}
- writeln('DisplayHint');
- {$ENDIF}
- if Assigned(F_Hint) and F_Hint.Visible then
- Exit; //==> Nothing to do
-
- with F_Hint do
- begin
- L_Hint.Text := AHint;
- Width := FFont.TextWidth(AHint) + (Border * 2) + (Margin * 2);
- Height := FFont.Height + (Border * 2) + (Margin * 2);
- if Shadow > 0 then
- begin
- F_Shadow.SetPosition(Pt.X+Shadow, Pt.Y+Shadow, Width, Height);
- F_Shadow.Show;
- end;
- L_Hint.SetPosition(Border, Border, Width - (Border * 2), Height - (Border * 2));
- SetPosition(Pt.X, Pt.Y, Width, Height);
- Show;
- end;
+ T_Chrono.Enabled:= True;
end;
-procedure HideHint;
+procedure TfpgHintWindow.FormHide(Sender: TObject);
begin
- {$IFDEF DEBUG}
- writeln('HideHint');
- {$ENDIF}
- if Assigned(F_Hint) and F_Hint.Visible then
- F_Hint.Hide;
+ T_Chrono.Enabled := False;
+ if Assigned(F_Shadow) then
+ F_Shadow.Hide;
end;
-
-{ TF_Hint }
-
-procedure TF_Hint.FormShow(Sender: TObject);
+function TfpgHintWindow.GetText: TfpgString;
begin
- T_Chrono.Enabled:= True;
+ Result := L_Hint.Text;
end;
-procedure TF_Hint.FormHide(Sender: TObject);
+procedure TfpgHintWindow.SetText(const AValue: TfpgString);
begin
- T_Chrono.Enabled := False;
- if Assigned(F_Shadow) then
- F_Shadow.Hide;
+ L_Hint.Text := AValue;
end;
-procedure TF_Hint.T_ChronoFini(Sender: TObject);
+procedure TfpgHintWindow.T_ChronoFini(Sender: TObject);
begin
{$IFDEF DEBUG}
writeln('TF_Hint.T_ChronoFini timer fired');
@@ -120,19 +120,19 @@ begin
Hide;
end;
-procedure TF_Hint.SetShadow(AValue: Integer);
+procedure TfpgHintWindow.SetShadow(AValue: Integer);
begin
if FShadow <> AValue then
FShadow := AValue;
end;
-procedure TF_Hint.SetBorder(AValue: Integer);
+procedure TfpgHintWindow.SetBorder(AValue: Integer);
begin
if FBorder <> AValue then
FBorder := AValue;
end;
-procedure TF_Hint.SetTime(AValue: Integer);
+procedure TfpgHintWindow.SetTime(AValue: Integer);
begin
if FTime <> AValue then
begin
@@ -141,32 +141,41 @@ begin
end;
end;
-procedure TF_Hint.SetLTextColor(AValue: Tfpgcolor);
+procedure TfpgHintWindow.SetLTextColor(AValue: Tfpgcolor);
begin
if L_Hint.TextColor <> AValue then
L_Hint.TextColor := AValue
end;
-procedure TF_Hint.SetLBackgroundColor(AValue: Tfpgcolor);
+procedure TfpgHintWindow.SetLBackgroundColor(AValue: Tfpgcolor);
begin
if L_Hint.BackgroundColor <> AValue then
L_Hint.BackgroundColor := AValue
end;
-procedure TF_Hint.SetShadowColor(AValue: Tfpgcolor);
+procedure TfpgHintWindow.SetShadowColor(AValue: Tfpgcolor);
begin
if F_Shadow.BackgroundColor <> AValue then
F_Shadow.BackgroundColor := AValue;
end;
-constructor TF_Hint.Create(AOwner: TComponent);
+procedure TfpgHintWindow.HandleShow;
+begin
+ // This is so the Shadow Window is below the Hint Window.
+ if Shadow > 0 then
+ begin
+ F_Shadow.SetPosition(Left+Shadow, Top+Shadow, Width, Height);
+ F_Shadow.Show;
+ end;
+ inherited HandleShow;
+end;
+
+constructor TfpgHintWindow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Name := 'F_Hint';
WindowPosition := wpUser;
WindowType := wtPopup;
-// WindowAttributes := [waBorderless];
-// BorderLess := True;
Sizeable := False;
BackgroundColor:= clBlack;
FFont := fpgGetFont('#Label1');
@@ -184,13 +193,18 @@ begin
OnHide := @FormHide;
end;
+procedure TfpgHintWindow.SetPosition(aleft, atop, awidth, aheight: TfpgCoord);
+begin
+ inherited SetPosition(aleft, atop, awidth, aheight);
+ L_Hint.SetPosition(Border, Border, Width - (Border * 2), Height - (Border * 2));
+end;
+
constructor TF_Shadow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Name := 'F_Shadow';
WindowPosition := wpUser;
WindowType := wtPopup;
-// BorderLess := True;
Sizeable := False;
BackgroundColor := clGray;
end;
diff --git a/src/gui/gui_label.pas b/src/gui/gui_label.pas
index 22c00fa8..20f5cfb3 100644
--- a/src/gui/gui_label.pas
+++ b/src/gui/gui_label.pas
@@ -45,10 +45,10 @@ type
function GetFontDesc: string;
procedure SetAutoSize(const AValue: boolean);
procedure SetFontDesc(const AValue: string);
- procedure SetText(const AValue: string);
+ procedure SetText(const AValue: TfpgString);
procedure ResizeLabel;
protected
- FText: string;
+ FText: TfpgString;
FFont: TfpgFont;
FTextHeight: integer;
procedure HandlePaint; override;
@@ -57,7 +57,7 @@ type
property AutoSize: boolean read FAutoSize write SetAutoSize default False;
property Layout: TLayout read FLayout write SetLayout default tlTop;
property FontDesc: string read GetFontDesc write SetFontDesc;
- property Text: string read FText write SetText;
+ property Text: TfpgString read FText write SetText;
property LineSpace: integer read FLineSpace write FLineSpace default 2;
public
constructor Create(AOwner: TComponent); override;
@@ -169,7 +169,7 @@ begin
ResizeLabel;
end;
-procedure TfpgCustomLabel.SetText(const AValue: string);
+procedure TfpgCustomLabel.SetText(const AValue: TfpgString);
begin
if FText <> AValue then
begin
generated by cgit v1.2.3-70-g09d2 (git 2.47.1) at 2024-12-26 06:54:13 +0000