paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-27 10:14:03 +02:00
Code Issues Packages Projects Releases Wiki Activity

HintWindow changes

Browse Source 
Shane

git-svn-id: trunk@403 -
This commit is contained in:
lazarus 2001-11-09 19:14:25 +00:00
parent 9864bec26b
commit 40cb0d378a
13 changed files with 344 additions and 22 deletions

1
.gitattributes vendored
View File

@ -346,6 +346,7 @@ lcl/include/form.inc svneol=native#text/pascal
lcl/include/graphic.inc svneol=native#text/pascal
lcl/include/graphiccontrol.inc svneol=native#text/pascal
lcl/include/graphicsobject.inc svneol=native#text/pascal
lcl/include/hintwindow.inc svneol=native#text/pascal
lcl/include/hkeys.inc svneol=native#text/pascal
lcl/include/imglist.inc svneol=native#text/pascal
lcl/include/interfacebase.inc svneol=native#text/pascal

71
designer/designer.pp
View File

@ -27,7 +27,7 @@ interface
uses
Classes, LCLLinux, Forms, Controls, LMessages, Graphics, ControlSelection,
CustomFormEditor, FormEditor, UnitEditor, CompReg, Menus, AlignCompsDlg,
SizeCompsDlg, ScaleCompsDlg;
SizeCompsDlg, ScaleCompsDlg, ExtCtrls;
type
TOnGetSelectedComponentClass = procedure(Sender: TObject;
@ -67,9 +67,13 @@ type
FBringToFrontMenuItem: TMenuItem;
FSendToBackMenuItem: TMenuItem;
//hint stuff
FHintTimer : TTimer;
FHintWIndow : THintWindow;
function GetIsControl: Boolean;
procedure SetIsControl(Value: Boolean);
procedure InvalidateWithParent(AComponent: TComponent);
Procedure HintTimer(sender : TObject);
protected
MouseDownComponent, MouseDownSender : TComponent;
MouseDownPos, MouseUpPos, LastMouseMovePos : TPoint;
@ -160,6 +164,18 @@ begin
FHasSized:=false;
FGridColor:=clGray;
FDuringPaintControl:=false;
FHintTimer := TTimer.Create(nil);
FHintTimer.Interval := 500;
FHintTimer.Enabled := False;
FHintTimer.OnTimer := @HintTimer;
FHintWindow := THintWindow.Create(nil);
FHIntWindow.Visible := False;
FHintWindow.Caption := 'This is a hint window'#13#10'NEat huh?';
FHintWindow.HideInterval := 4000;
FHintWindow.AutoHide := True;
end;
destructor TDesigner.Destroy;
@ -271,6 +287,7 @@ var i,
SelectedCompClass: TRegisteredComponent;
NonVisualComp: TComponent;
Begin
FHintTimer.Enabled := False;
FHasSized:=false;
if (MouseDownComponent<>nil) or (getParentForm(Sender)=nil) then exit;
MouseDownComponent:=Sender;
@ -378,6 +395,8 @@ var
SenderOrigin:TPoint;
SelectedCompClass: TRegisteredComponent;
Begin
FHintTimer.Enabled := False;
SenderParentForm:=GetParentForm(Sender);
if (MouseDownComponent=nil) or (SenderParentForm=nil) then exit;
@ -499,6 +518,12 @@ var
SenderParentForm:TCustomForm;
MouseX, MouseY :integer;
Begin
try
FHintTimer.Enabled := False;
FHintTimer.Enabled := True;
if FHintWindow.Visible then
FHintWindow.Visible := False;
if MouseDownComponent=nil then exit;
SenderParentForm:=GetParentForm(Sender);
@ -561,7 +586,12 @@ Begin
end else begin
ControlSelection.ActiveGrabber:=nil;
end;
LastMouseMovePos:=Point(MouseX,MouseY);
finally
SenderOrigin:=GetFormRelativeControlTopLeft(Sender);
MouseX:=Message.Pos.X+SenderOrigin.X;
MouseY:=Message.Pos.Y+SenderOrigin.Y;
LastMouseMovePos:=Point(MouseX,MouseY);
end;
end;
procedure TDesigner.MouseRightUpOnControl(Sender : TControl; Message:TLMMouse);
@ -569,6 +599,8 @@ var
MouseX, MouseY : Integer;
SenderOrigin: TPoint;
begin
FHintTimer.Enabled := False;
SenderOrigin:=GetFormRelativeControlTopLeft(Sender);
MouseX:=Message.Pos.X+SenderOrigin.X;
MouseY:=Message.Pos.Y+SenderOrigin.Y;
@ -664,6 +696,9 @@ Begin
else
if ((Message.Msg >= LM_KeyFIRST) and (Message.Msg <= LM_KeyLAST)) then
Result:=true;
// else
// if ((Message.Msg >= CM_MOUSEENTER) and (Message.Msg <= CM_MOUSELEAVE)) then
// Result:=true;
case Message.Msg of
LM_PAINT: Result:=PaintControl(Sender,TLMPaint(Message));
@ -675,6 +710,7 @@ Begin
LM_MOUSEMOVE: MouseMoveOnControl(Sender, TLMMouse(Message));
LM_SIZE: Result:=SizeControl(Sender,TLMSize(Message));
LM_MOVE: Result:=MoveControl(Sender,TLMMove(Message));
// CM_MOUSELEAVE: Writeln('MOUSELEAVE!!!!!!!!!!!!');//Result:=MoveControl(Sender,TLMMove(Message));
end;
end;
end;
@ -984,7 +1020,36 @@ begin
if ControlSelection.Count = 1 then begin
AComponent:= ControlSelection.Items[0].Component;
if AComponent is TControl then TControl(AComponent).SendToBack;
end;
end;
end;
Procedure TDesigner.HintTimer(sender : TObject);
var
Rect : TRect;
AHint : String;
Control : TControl;
Position : TPoint;
begin
FHintTimer.Enabled := False;
Position := Mouse.CursorPos;
if ((Position.X < FCustomForm.LEft) or (Position.X > (FCustomForm.Left+FCustomForm.Width)) or (Position.Y < FCustomForm.Top) or (Position.Y > (FCustomForm.Top+FCustomForm.Height))) then Exit;
Position := FCustomForm.ScreenToClient(Position);
Control := FCustomForm.ControlAtPos(Position,True);
if not Assigned(Control) then
Control := FCustomForm;
AHint := Control.Name + ' : '+Control.ClassName;
AHint := AHint + #10+'Left : '+Inttostr(Control.Left)+ ' Top : '+Inttostr(Control.Top)+
#10+'Width : '+Inttostr(Control.Width)+ ' Height : '+Inttostr(Control.Height);
Rect := FHintWindow.CalcHintRect(0,AHint,nil); //no maxwidth
Rect.Left := LastMouseMovePos.X+FCustomForm.LEft+10;
Rect.Top := LastMouseMovePos.Y+FCustomForm.Top;
Rect.Right := Rect.Left + Rect.Right;
Rect.Bottom := Rect.Top + Rect.Bottom;
FHintWindow.ActivateHint(Rect,AHint);
end;

6
lcl/controls.pp
View File

@ -755,6 +755,8 @@ TCMDialogKey = TLMKEY;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
@ -1140,6 +1142,10 @@ end.
{ =============================================================================
$Log$
Revision 1.24 2001/11/09 19:14:23 lazarus
HintWindow changes
Shane
Revision 1.23 2001/10/31 16:29:21 lazarus
Fixed the gtk mousemove bug where the control gets the coord's based on it's parent instead of itself.
Shane

30
lcl/forms.pp
View File

@ -211,10 +211,35 @@ type
end;
TFormClass = class of TForm;
{THintWindow}
THintWindow = class(TCustomForm)
private
FActivating: Boolean;
FAutoHide : Boolean;
FAutoHideTimer : TComponent;
FHideInterval : Integer;
Procedure SetAutoHide(Value : Boolean);
Procedure AutoHideHint(Sender : TObject);
Procedure SetHideInterval(Value : Integer);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ActivateHint(Rect: TRect; const AHint: String); virtual;
function CalcHintRect(MaxWidth: Integer; const AHint: String; AData: Pointer): TRect; virtual;
property Color;
property AutoHide : Boolean read FAutoHide write SetAutoHide;
property HideInterval : Integer read FHideInterval write SetHideInterval;
end;
TScreen = class(TComponent)
private
FFormList: TList;
FHintFont : TFont;
FPixelsPerInch : integer;
Function GetFormCount: Integer;
Function GetForms(IIndex: Integer): TForm;
@ -228,6 +253,7 @@ type
property FormCount: Integer read GetFormCount;
property Forms[Index: Integer]: TForm read GetForms;
property PixelsPerInch : integer read FPixelsPerInch;
property HintFont : TFont read FHintFont;
property Height : Integer read Getheight;
property Width : Integer read GetWidth;
end;
@ -314,7 +340,7 @@ implementation
uses
Buttons, StdCtrls, Interfaces, LResources, dialogs {,designer};
Buttons, StdCtrls, Interfaces, LResources, dialogs,ExtCtrls {,designer};
const
FocusMessages : Boolean = true;
@ -433,6 +459,8 @@ end;
{$I Customform.inc}
{$I screen.inc}
{$I application.inc}
{$I hintwindow.inc}
initialization
Screen:= TScreen.Create(nil);

8
lcl/graphics.pp
View File

@ -456,11 +456,13 @@ type
destructor Destroy; override;
Procedure Draw(X,Y: Integer; Graphic : TGraphic);
Procedure FillRect(const Rect : TRect);
Procedure Rectangle(X1,Y1,X2,Y2 : Integer);
Procedure Rectangle(X1,Y1,X2,Y2 : Integer); overload;
Procedure Rectangle(const Rect: TRect); overload;
Procedure Line(X1,Y1,X2,Y2 : Integer);
Procedure MoveTo(X1,Y1 : Integer);
Procedure LineTo(X1,Y1 : Integer);
Procedure TextOut(X,Y: Integer; const Text: String);
Procedure TextRect(Rect: TRect; X,Y : Integer; const Text : String);
function TextExtent(const Text: string): TSize;
function TextHeight(const Text: string): Integer;
function TextWidth(const Text: string): Integer;
@ -743,6 +745,10 @@ end.
{ =============================================================================
$Log$
Revision 1.16 2001/11/09 19:14:23 lazarus
HintWindow changes
Shane
Revision 1.15 2001/10/25 19:02:18 lazarus
MG: fixed parsing constants with OR, AND, XOR, MOD, DIV, SHL, SHR

28
lcl/include/canvas.inc
View File

@ -247,6 +247,30 @@ begin
LCLLinux.Rectangle(FHandle, X1, Y1, X2, Y2);
end;
{------------------------------------------------------------------------------
Method: TCanvas.Rectangle
Params: Rect
Returns: Nothing
------------------------------------------------------------------------------}
procedure TCanvas.Rectangle(const Rect: TRect);
begin
Rectangle(Rect.Left, REct.Top, Rect.RIght, REct.Bottom);
end;
{------------------------------------------------------------------------------
Method: TCanvas.TextRect
Params: Rect,X,Y,Text
Returns: Nothing
------------------------------------------------------------------------------}
Procedure TCanvas.TextRect(Rect: TRect; X,Y : Integer; const Text : String);
begin
RequiredState([csHandleValid, csFontValid, csBrushValid]);
ExtTextOut(FHandle, X, Y, 0 { <-- TODO: FTextFlags}, @Rect, pChar(Text), Length(Text), nil);
MoveTo(X + TextWidth(Text), Y);
end;
{------------------------------------------------------------------------------
Method: TCanvas.TextOut
Params: X,Y,Text
@ -598,6 +622,10 @@ end;
{ =============================================================================
$Log$
Revision 1.11 2001/11/09 19:14:23 lazarus
HintWindow changes
Shane
Revision 1.10 2001/10/07 07:28:33 lazarus
MG: fixed setpixel and TCustomForm.OnResize event

127
lcl/include/hintwindow.inc Normal file
View File

@ -0,0 +1,127 @@
{ THintWindow }
constructor THintWindow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fCompStyle := csHintWindow;
parent := nil;
Canvas.Font := Screen.HintFont;
color := clInfoBk;
Caption := 'THintWIndow';
SetBounds(1,1,25,25);
FHideInterval := 3000;
FAutoHideTimer := TTimer.Create(self);
TTimer(FAutoHideTImer).Interval := HideInterval;
TTimer(FAutoHideTimer).Enabled := False;
TTimer(FAutoHideTimer).OnTimer := @AutoHideHint;
end;
destructor THintWIndow.Destroy;
begin
fAutoHideTimer.Free;
inherited;
end;
Procedure THintWindow.SetHideInterval(Value : Integer);
Begin
FHideInterval := Value;
TTimer(FAutoHideTimer).Interval := FHideInterval;
end;
Procedure THintWindow.SetAutoHide(Value : Boolean);
Begin
FAutoHide := Value;
if not(value) then
TTimer(FAutoHideTimer).Enabled := False;
end;
Procedure THintWindow.AutoHideHint(Sender : TObject);
Begin
TTimer(FAutoHideTimer).Enabled := False;
if Visible then Hide;
End;
procedure THintWindow.Paint;
var
Rect: TRect;
DefaultDraw: Boolean;
begin
Rect := ClientRect;
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.Rectangle(Rect);
Canvas.TextRect(Rect, 3, 3, Caption);
end;
procedure THintWindow.ActivateHint(Rect: TRect; const AHint: String);
begin
FActivating := True;
try
Caption := AHint;
if Rect.Bottom > Screen.Height then
begin
Rect.Top := Screen.Height - (Rect.Bottom - Rect.Top);
Rect.Bottom := Screen.Height;
end;
if Rect.Right > Screen.Width then
begin
Rect.Left := Screen.Width - (Rect.Right - Rect.Left);
Rect.Right := Screen.Width;
end;
if Rect.Left < 0 then Rect.Left := 0;
if Rect.Bottom < 0 then Rect.Bottom := 0;
SetBounds(Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
Visible := True;
TTimer(FAutoHideTimer).Enabled := False;
TTimer(FAutoHideTimer).Enabled := FAutoHide;
finally
FActivating := False;
end;
end;
function THintWindow.CalcHintRect(MaxWidth: Integer; const AHint: String;
AData: Pointer): TRect;
var
Temp : Integer;
Num : Integer;
tempHint : String;
LongestLine : String;
Lines : Integer;
begin
Result.Left := 0;
Result.Top := 0;
TempHint := AHint;
LongestLine := '';
num := pos(#10,TempHint);
Lines := 1;
if Num > 0 then
Begin
//set TempHint to the longest line.
//set Lines to the number of lines.
while num > 0 do
Begin
inc(Lines);
if Canvas.TextWidth(copy(TempHint,1,num-1)) > Canvas.TextWidth(LongestLine) then
LongestLine := Copy(TempHint,1,num-1);
delete(TempHint,1,num);
Num := pos(#10,TempHint);
end;
end;
if Canvas.TextWidth(copy(TempHint,1,Length(TempHint))) > Canvas.TextWidth(LongestLine) then
LongestLine := Copy(TempHint,1,Length(TempHint));
TempHint := LongestLine;
if ((MaxWidth > 0) and (Canvas.TextWidth(TempHint) > MaxWidth)) then
Result.Right := Result.Left + MaxWidth
else
Result.Right := Result.Left + Canvas.TextWidth(TempHint);
Result.Bottom := result.Top + (Lines * (Canvas.TextHeight(AHint)));
Inc(Result.Bottom, 4);
Dec(Result.Top, 2);
Inc(Result.Right, 8);
end;

5
lcl/include/screen.inc
View File

@ -13,6 +13,11 @@ begin
inherited Create(AOwner);
FFormList := TList.Create;
FPixelsPerInch:= ScreenInfo.PixelsPerInchX;
FHintFont := TFont.Create;
// FHintFont.Name := 'courier';
FHintFont.Style := [];
FHintFont.Size := 12;
FHintFont.Pitch := fpDefault;
end;
{------------------------------------------------------------------------------

8
lcl/include/wincontrol.inc
View File

@ -609,6 +609,7 @@ Begin
with Result do
begin
P := Point(Pos.X - Left, Pos.Y - Top);
//MWE: rewrote it a bit to get it more readable
if PtInRect(ClientRect,P)
and (
@ -1694,7 +1695,7 @@ begin
Assert(False, Format('trace:[TWinControl.AttachSignals] %s', [ClassName]));
// Attach callbacks
SetCallback(LM_DESTROY);
SetCallback(LM_SHOWWINDOW);
SetCallback(LM_SHOWWINDOW); //This does the SHOW and HIDE
SetCallback(LM_FOCUS);
//Obsolete ?? SetCallback(LM_SIZEALLOCATE);
SetCallback(LM_WINDOWPOSCHANGED);
@ -1721,7 +1722,6 @@ begin
{ *** These need to be implemented yet
hide
state-changed
}
end;
@ -1931,6 +1931,10 @@ end;
{ =============================================================================
$Log$
Revision 1.41 2001/11/09 19:14:23 lazarus
HintWindow changes
Shane
Revision 1.40 2001/10/31 16:29:22 lazarus
Fixed the gtk mousemove bug where the control gets the coord's based on it's parent instead of itself.
Shane

4
lcl/interfaces/gtk/gtkcallback.inc
View File

@ -1206,6 +1206,10 @@ end;
{ =============================================================================
$Log$
Revision 1.41 2001/11/09 19:14:24 lazarus
HintWindow changes
Shane
Revision 1.40 2001/11/01 21:30:35 lazarus
Changes to Messagebox.
Added line to CodeTools to prevent duplicate USES entries.

48
lcl/interfaces/gtk/gtkobject.inc
View File

@ -1175,22 +1175,26 @@ begin
if not (Sender is TSpeedButton) then
begin
pWidget := pgtkWidget(TWinControl(Sender).Handle);
//if Sender is TCustomForm then
//writeln('[TgtkObject.ResizeChild] ',Sender.ClassName,' ',Width,',',Height);
if Sender is TCustomForm then
//gdk_window_resize(pWidget^.Window, Width,Height);
gtk_widget_set_usize(pWidget, -1, -1);
gtk_widget_set_usize(pWidget, -1, -1);
gtk_widget_set_usize(pWidget, Width, Height);
if not ((Parent = nil) or (Sender is TCustomForm)) then
if Sender is TCustomForm then
gtk_window_set_default_size(PgtkWindow(pWidget),Width,Height);
if not ((Parent = nil) or (Sender is TCustomForm)) then
begin
pFixed := GetFixedWidget(PGtkWidget(Parent.Handle));
if pFixed <> nil then begin
gtk_fixed_move(pFixed, pWidget, Left, Top);
end
if pFixed <> nil then
begin
gtk_fixed_move(pFixed, pWidget, Left, Top);
end
else Assert(False, 'Trace:ERROR!!!! - no Fixed Widget found to use when resizing....');
end
else begin
else
begin
gtk_widget_set_uposition(pWidget, Left, Top);
end;
end;
@ -1579,9 +1583,6 @@ begin
LM_MOUSEMOVE:
begin
// if ((sender is tCustomForm) )then
// ConnectSignal(gFixed, 'motion-notify-event', @GTKMotionNotify)
// else
ConnectSignal(gFixed, 'motion-notify-event', @GTKMotionNotify, GDK_POINTER_MOTION_MASK)
end;
@ -2055,6 +2056,23 @@ begin
P := gtk_frame_new(' ');
gtk_frame_set_shadow_type(pGtkFrame(P),GTK_SHADOW_NONE);
end;
csHintWindow :
Begin
p := gtk_window_new(FormStyleMap[bsToolWindow]{gtk_window_Popup});
gtk_window_set_policy (GTK_WINDOW (p), 0, 0, 0);
// Box := gtk_vbox_new(False, 0);
// gtk_container_add(p, Box);
// gtk_widget_show(Box);
// Create the form client area
TempWidget := gtk_fixed_new();
gtk_container_add(p, TempWidget);// gtk_box_pack_end(Box, TempWidget, True, True, 0);
gtk_widget_show(TempWidget);
SetFixedWidget(p, TempWidget);
SetMainWidget(p, TempWidget);
gtk_widget_show(p);
end;
csLabel :
begin
@ -2429,7 +2447,7 @@ begin
finally
strDispose(pStr);
end;
// gtk_object_set_data(PGtkObject(TPage(Child).Handle), 'Owner', pgtkwidget(TWinControl(Parent).handle));
// gtk_object_set_data(PGtkObject(TPage(Child).Handle), '1', pgtkwidget(TWinControl(Parent).handle));
end;
{------------------------------------------------------------------------------}
@ -3118,6 +3136,10 @@ end;
{ =============================================================================
$Log$
Revision 1.68 2001/11/09 19:14:24 lazarus
HintWindow changes
Shane
Revision 1.67 2001/11/09 14:33:41 lazarus
MG: fixed GetItemIndex-Handle-NotAllocated-Crash bug

29
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -1148,6 +1148,9 @@ function TgtkObject.ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint; Rect: P
var
pStr: PChar;
Width, Height: Integer;
NewText,oldText : String;
NUm : Integer;
Line : Integer;
begin
Assert(False, Format('trace:> [TgtkObject.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count]));
Result := IsValidDC(DC);
@ -1185,8 +1188,26 @@ begin
Y := Rect^.Top;
end;
SelectGDKTextProps(DC);
gdk_draw_text(Drawable, CurrentFont^.GDIFontObject, GC,
X, Y + 10 {TODO: query font height}, pStr, Count);
Line := 1;
OldText := StrPas(pStr);
Num := pos(#10,OldText);
if Num = 0 then
gdk_draw_text(Drawable, CurrentFont^.GDIFontObject, GC, X, Y + 10 {TODO: query font height}, pStr, Count)
else
Begin //write multiple lines
while NUm > 0 do
begin
NewText := Copy(OldText,1,Num);
gdk_draw_text(Drawable, CurrentFont^.GDIFontObject, GC, X, Y + (Line*10) {TODO: query font height}, pchar(NewText), Length(NewText));
Delete(OldText,1,Num);
Num := pos(#10,OldText);
inc(line);
end;
if OldText <> '' then
gdk_draw_text(Drawable, CurrentFont^.GDIFontObject, GC, X, Y + (Line*10) {TODO: query font height}, pchar(OldText), length(OldText));
end;
finally
StrDispose(pStr);
end;
@ -3605,6 +3626,10 @@ end;
{ =============================================================================
$Log$
Revision 1.47 2001/11/09 19:14:25 lazarus
HintWindow changes
Shane
Revision 1.46 2001/10/31 16:29:23 lazarus
Fixed the gtk mousemove bug where the control gets the coord's based on it's parent instead of itself.
Shane

1
lcl/vclglobals.pp
View File

@ -84,6 +84,7 @@ csBitBtn = 44;
csCListBox = 45;
csSpeedButton = 46;
csPopupMenu = 47;
csHintWindow = 48;
type
//TODO: check this against lcllinux