Menu
▾
▴
[Pythianproject-cvsmail] CVS: Prototypes/GUISystem StartupForm.pas,1.12,1.13 vglClasses.pas,1.10,1.11 vglEdits.pas,1.2,1.3 vglStdCtrls.pas,1.9,1.10
|
From: Michael H. <mh...@us...> - 2001-01-06 19:52:41
|
Update of /cvsroot/pythianproject/Prototypes/GUISystem
In directory usw-pr-cvs1:/tmp/cvs-serv29046/GUISystem
Modified Files:
StartupForm.pas vglClasses.pas vglEdits.pas vglStdCtrls.pas
Log Message:
added drag'n'drop, alerts -mike
Index: StartupForm.pas
===================================================================
RCS file: /cvsroot/pythianproject/Prototypes/GUISystem/StartupForm.pas,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -r1.12 -r1.13
*** StartupForm.pas 2001/01/02 21:46:20 1.12
--- StartupForm.pas 2001/01/06 19:52:48 1.13
***************
*** 48,53 ****
procedure ButtonOnclick(Sender:TObject);
procedure CB1OnChange(Sender:TObject);
!
procedure ManagerOnFocusChange(Sender:TObject);
procedure go;
--- 48,55 ----
procedure ButtonOnclick(Sender:TObject);
procedure CB1OnChange(Sender:TObject);
! procedure SBOnChange(Sender: TObject; ScrollCode: TvglScrollCode; var ScrollPos: Integer);
procedure ManagerOnFocusChange(Sender:TObject);
+ procedure DragBoxOnDragOver(what:TvglDragObject; var Accept:boolean);
+ procedure DragBoxOnDragDrop(what:TvglDragObject);
procedure go;
***************
*** 109,113 ****
begin
// test code
- InterfaceManager.Desktop.TestText.Text := IntToStr(X)+','+IntToStr(Y)+': '+InterfaceManager.Desktop.GetComponentAt(X,Y).Name;
InterfaceManager.MouseMove(X,Y);
end;
--- 111,114 ----
***************
*** 212,218 ****
Label1 := TvglTextBox.Create('Label1',InterfaceManager.Desktop);
! Label1.Top := 192;
Label1.Left := 468;
! Label1.Color := clBlack;
Label1.Font := 'Courier New';
Label1.Caption := 'FOCUS LOST!';
--- 213,219 ----
Label1 := TvglTextBox.Create('Label1',InterfaceManager.Desktop);
! Label1.Top := 220;
Label1.Left := 468;
! Label1.Color := clWhite;
Label1.Font := 'Courier New';
Label1.Caption := 'FOCUS LOST!';
***************
*** 224,229 ****
SB.Height := 13;
SB.Width := 150;
! SB.Position := 15;
! SB.PageSize := 10;
LB := TvglSimpleListBox.Create('SimpleListBoxTest', InterfaceManager.Desktop);
--- 225,233 ----
SB.Height := 13;
SB.Width := 150;
! SB.Max := 255;
! SB.Min := 0;
! SB.Position := 255;
! SB.PageSize := 50;
! SB.OnScroll := SBOnChange;
LB := TvglSimpleListBox.Create('SimpleListBoxTest', InterfaceManager.Desktop);
***************
*** 253,256 ****
--- 257,262 ----
DragBox := TvglDragBox.Create('DragBox1',InterfaceManager.Desktop);
DragBox.Bounds := Rect(500,400,550,450);
+ DragBox.OnDragOver := DragBoxOnDragOver;
+ DragBox.OnDragDrop := DragBoxOnDragDrop;
InterfaceManager.SetNewFocus(LB);
***************
*** 286,289 ****
--- 292,312 ----
Label1.Lines.Text := 'FOCUS LOST!';
end;
+ end;
+
+ procedure TfrmStartup.DragBoxOnDragOver(what: TvglDragObject;
+ var Accept: boolean);
+ begin
+ if what.from = Image1 then accept := true else accept := false;
+ end;
+
+ procedure TfrmStartup.SBOnChange(Sender: TObject; ScrollCode: TvglScrollCode;
+ var ScrollPos: Integer);
+ begin
+ Panel1.TotalAlpha := (1 / 255) * ScrollPos;
+ end;
+
+ procedure TfrmStartup.DragBoxOnDragDrop(what: TvglDragObject);
+ begin
+ InterfaceManager.VGLAlert('You dropped object ['+what.from.Name+'] onto the draggable box! ABCDEFGHIJKLIMNOPQRSTUVWXYZ - this is a test message to force auto alert resizing');
end;
Index: vglClasses.pas
===================================================================
RCS file: /cvsroot/pythianproject/Prototypes/GUISystem/vglClasses.pas,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -r1.10 -r1.11
*** vglClasses.pas 2001/01/02 21:46:20 1.10
--- vglClasses.pas 2001/01/06 19:52:48 1.11
***************
*** 34,41 ****
- Pretty much everything! :)
- - Bitmapped controls
- Resource sharing (done except reference counting/garbage collection)
- Name generation/usage (!)
! - Display list optimizations
- Components
--- 34,40 ----
- Pretty much everything! :)
- Resource sharing (done except reference counting/garbage collection)
- Name generation/usage (!)
! - Display list optimizations (don't appear to have any effect so uncompleted)
- Components
***************
*** 49,55 ****
- Global Mouse and Keyboard events
- Updating (many uses - f.e. Timer)
History:
! - 13/12/00 - the code size is about 50kB (vglClasses.Pas), all files
have now about 83kB (vglClasses.pas, vglStdCtrls.pas, vglCheckBox.pas) :)
--- 48,60 ----
- Global Mouse and Keyboard events
- Updating (many uses - f.e. Timer)
+ - Bitmapped controls
+
+ Bugs:
+ - Severe bug with TvglAlert memory management (cannot be released without causing an External Exception in MouseMove)
+ currently causes memory leak :(
History:
! - January 2001: Drag'n'drop added. Alert box added
! - 13th December 2000: the code size is about 50kB (vglClasses.Pas), all files
have now about 83kB (vglClasses.pas, vglStdCtrls.pas, vglCheckBox.pas) :)
***************
*** 108,111 ****
--- 113,117 ----
Graphics, // for colour constants
OpenGL,
+ Trace,
GLCanvas;
***************
*** 115,119 ****
VGL_SKIN_1 = 'skin1.png'; // alpha skin
VGL_SKINRECT_BACKGROUND :TRect = (Left:3;Top:51;Right:134;Bottom:175);
- VGL_SKINRECT_BUTTON :TRect = (Left:3;Top:3;Right:153;Bottom:48);
VGL_SKINRECT_MOUSECURSOR :TRect = (Left:3;Top:175;Right:35;Bottom:207);
--- 121,124 ----
***************
*** 151,154 ****
--- 156,163 ----
end;
+ TvglDragObject = class; // forward
+
+ TVGLDragOverEvent = procedure(what:TvglDragObject; var Accept:boolean) of object;
+ TVGLDragDropEvent = procedure(what:TvglDragObject) of object;
TVGLMouseButtonEvent = procedure(mb,x,y:integer) of object;
TVGLMouseMoveEvent = procedure(x,y:integer) of object;
***************
*** 173,190 ****
-
// an abstract class from which other components are derived
TvglComponent = class(TvglBase)
- private
- FOnGlobalKeyUp: TVGLKeyboardEvent;
- FOnKeyDown: TVGLKeyboardEvent;
- FOnKeyUp: TVGLKeyboardEvent;
- FOnGlobalKeyDown: TVGLKeyboardEvent;
- FCached: boolean;
- procedure SetOnGlobalKeyDown(const Value: TVGLKeyboardEvent);
- procedure SetOnGlobalKeyUp(const Value: TVGLKeyboardEvent);
- procedure SetOnKeyDown(const Value: TVGLKeyboardEvent);
- procedure SetOnKeyUp(const Value: TVGLKeyboardEvent);
- function KeyDataToShiftState(KeyData: Longint): TShiftState;
protected
FFocusable: Boolean;
--- 182,187 ----
***************
*** 200,203 ****
--- 197,203 ----
FSavedMouseDown :TvglComponent;
FTextured :boolean; // use the skin? or use vector drawing
+ FVisible :boolean;
+ FReleased :boolean; // when true will be freed by the interface manager next cycle
+ // use when component needs to be destroyed but from itself
// cache vars here
***************
*** 212,222 ****
FOnGlobalMouseUp, FOnGlobalMouseDown :TVGLMouseButtonEvent;
FOnGlobalMouseMove :TVGLMouseMoveEvent;
!
FOnMouseEntry,FOnMouseExit,FOnMouseClick :TNotifyEvent;
FOnEnter: TVGLEntryExitEvent;
FOnExit: TVGLEntryExitEvent;
FOnChildAdd:TVGLChildEvent;
! FVisible :boolean;
!
procedure FreeChildren;
--- 212,226 ----
FOnGlobalMouseUp, FOnGlobalMouseDown :TVGLMouseButtonEvent;
FOnGlobalMouseMove :TVGLMouseMoveEvent;
! FOnDragOver :TVGLDragOverEvent;
FOnMouseEntry,FOnMouseExit,FOnMouseClick :TNotifyEvent;
FOnEnter: TVGLEntryExitEvent;
FOnExit: TVGLEntryExitEvent;
FOnChildAdd:TVGLChildEvent;
! FOnGlobalKeyUp: TVGLKeyboardEvent;
! FOnKeyDown: TVGLKeyboardEvent;
! FOnKeyUp: TVGLKeyboardEvent;
! FOnGlobalKeyDown: TVGLKeyboardEvent;
! FCached: boolean;
! FOnDragDrop: TVGLDragDropEvent;
procedure FreeChildren;
***************
*** 247,251 ****
--- 251,265 ----
procedure SetOnEnter(const Value: TVGLEntryExitEvent);
procedure SetOnExit(const Value: TVGLEntryExitEvent);
+ procedure SetOnGlobalKeyDown(const Value: TVGLKeyboardEvent);
+ procedure SetOnGlobalKeyUp(const Value: TVGLKeyboardEvent);
+ procedure SetOnKeyDown(const Value: TVGLKeyboardEvent);
+ procedure SetOnKeyUp(const Value: TVGLKeyboardEvent);
+ function KeyDataToShiftState(KeyData: Longint): TShiftState;
+
+ // drag'n'drop
+ function CanAcceptDragObject(dragObject :TvglDragObject):boolean; virtual ; // is overridden by descendants to accept drag objects
+ procedure DragDrop(dragObject:TvglDragObject); virtual ; // called when an object is dragged
+
// focusing
function GetFocused: Boolean;
***************
*** 287,290 ****
--- 301,305 ----
constructor Create(aName:string; AOwner:TvglComponent);
destructor Destroy; override ; // destroying an object also destroys its children
+ procedure Release;
procedure MoveTo(x,y:integer);
***************
*** 337,340 ****
--- 352,357 ----
property OnEnter: TVGLEntryExitEvent read FOnEnter write SetOnEnter;
property OnExit: TVGLEntryExitEvent read FOnExit write SetOnExit;
+ property OnDragOver: TVGLDragOverEvent read FOnDragOver write FOnDragOver;
+ property OnDragDrop :TVGLDragDropEvent read FOnDragDrop write FOnDragDrop;
end;
***************
*** 343,347 ****
DragOrigin :TPoint;
CurPoint :TPoint;
! constructor Create(aDragOrigin:TPoint);
procedure StartDrag; virtual ;
procedure EndDrag; virtual ;
--- 360,367 ----
DragOrigin :TPoint;
CurPoint :TPoint;
! from :TvglComponent;
! Tag :integer;
! constructor Create(aFrom:TvglComponent; aDragOrigin:TPoint);
! destructor Destroy; override ;
procedure StartDrag; virtual ;
procedure EndDrag; virtual ;
***************
*** 359,363 ****
TvglDragCopyObject = class(TvglDragObject)
CopyComponent :TvglComponent;
! constructor Create(aDragOrigin:TPoint; aCopyComponent:TvglComponent);
end;
--- 379,383 ----
TvglDragCopyObject = class(TvglDragObject)
CopyComponent :TvglComponent;
! constructor Create(aFrom:TvglComponent; aDragOrigin:TPoint; aCopyComponent:TvglComponent);
end;
***************
*** 409,412 ****
--- 429,433 ----
end;
+
TvglDraggableImage = class(TvglImage)
protected
***************
*** 471,474 ****
--- 492,497 ----
NewMouseList, OldMouseList, TempMouseList :TvglObjList;
+ TestData :string;
+
procedure SetOnCreateDesktop(const Value: TCreateDesktopEvent);
***************
*** 483,486 ****
--- 506,513 ----
procedure UpdateDragObjects(newPos:TPoint);
procedure OverlayDragCopyObjects;
+ procedure ReleaseDragObjects;
+ function DragObjectOver(component:TvglComponent):TvglDragObject;
+
+ procedure VGLAlertFree(Sender:TObject);
public
property Focused: TvglComponent read FFocusedComponent;
***************
*** 501,504 ****
--- 528,532 ----
procedure DrawAll; virtual;
procedure DrawBorder(where:TRect; FImage:TGLBitmap); virtual ;
+ procedure VGLAlert(msg:string); // displays a general purpose alert
// resource management
***************
*** 525,529 ****
--- 553,559 ----
procedure CopyList(src,dest:TList);
function PointInRectInAcc(R: TRect; X, Y, XINACC, YINACC: Integer): Boolean;
+
implementation
+ uses vglStdCtrls;
function PointInRectInAcc(R: TRect; X, Y, XINACC, YINACC: Integer): Boolean;
***************
*** 641,649 ****
procedure TvglComponent.FreeChildren;
- var a:integer;
begin
! a := 0;
! while a < FChildren.Count do
! FChildren[a].Free;
end;
--- 671,679 ----
procedure TvglComponent.FreeChildren;
begin
! while FChildren.Count > 0 do
! begin
! FChildren[0].Free;
! end;
end;
***************
*** 763,769 ****
var i:integer;
begin
i := FChildren.IndexOf(child);
! if i = -1 then raise EVGLException.Create('TvglComponent.RemoveChild: Unknown child component');
! FChildren.Delete(i);
end;
--- 793,802 ----
var i:integer;
begin
+ TraceString('REMOVECHILD');
+ if not assigned(child) then raise EVGLException.Create('TvglComponent.RemoveChild: NIL parameter');
+ TraceString(' for '+child.name);
i := FChildren.IndexOf(child);
! if i = -1 then raise EVGLException.Create('TvglComponent.RemoveChild: Unknown child component ['+child.name+']');
! FChildren.Delete(i);
end;
***************
*** 877,880 ****
--- 910,923 ----
if FChildren[i] <> nil then
FChildren[i].Update(ElapsedTime);
+ i := 0;
+ while i < FChildren.Count do
+ begin
+ if FChildren[i].FReleased then
+ begin
+ TraceString('Releasing: '+Fchildren[i].name);
+ FChildren[i].Free;
+ end else
+ inc(i);
+ end;
end;
***************
*** 1111,1116 ****
--- 1154,1175 ----
end;
+ function TvglComponent.CanAcceptDragObject(
+ dragObject: TvglDragObject): boolean;
+ begin
+ if assigned(FOnDragOver) then
+ FOnDragOver(dragObject,result)
+ else Result := false;
+ end;
+ procedure TvglComponent.DragDrop(dragObject: TvglDragObject);
+ begin
+ if assigned(FOnDragDrop) then FOnDragDrop(dragObject);
+ end;
+ procedure TvglComponent.Release;
+ begin
+ FReleased := true;
+ end;
+
{ TvglObjList }
***************
*** 1140,1144 ****
DefaultTextured := true;
FDragObjects := TList.Create;
!
FLeft := 0; FTop := 0;
--- 1199,1203 ----
DefaultTextured := true;
FDragObjects := TList.Create;
! TestData := '';
FLeft := 0; FTop := 0;
***************
*** 1159,1163 ****
--- 1218,1227 ----
procedure TvglInterfaceManager.EndDrag(dragObj: TvglDragObject);
+ var c:TvglComponent;
begin
+ c := Desktop.GetComponentAt(dragObj.CurPoint.X,dragObj.CurPoint.Y);
+ if assigned(c) then
+ if c.CanAcceptDragObject(dragObj) then
+ c.DragDrop(dragObj);
dragObj.EndDrag;
if FDragObjects.IndexOf(DragObj) <> -1 then
***************
*** 1283,1286 ****
--- 1347,1352 ----
i:integer;
t:integer;
+ d:TvglDragObject;
+ c:TvglComponent;
begin
// send event
***************
*** 1327,1330 ****
--- 1393,1406 ----
// do drag ops
UpdateDragObjects(Point(X,Y));
+ c := Desktop.GetComponentAt(X,Y);
+ d := DragObjectOver(c);
+ if assigned(d) then
+ if c.CanAcceptDragObject(d) then
+ TestData := ' |accepts|'
+ else testData := ' |no accept|'
+ else testdata := '';
+
+ // update test label
+ Desktop.TestText.Text := IntToStr(X)+','+IntToStr(Y)+': '+Desktop.GetComponentAt(X,Y).Name + TestData;
end;
***************
*** 1334,1337 ****
--- 1410,1414 ----
Desktop.DoOnMouseUp(Button, x, y);
Desktop.DoOnGlobalMouseUp(button, X, Y);
+ ReleaseDragObjects;
end;
***************
*** 1595,1603 ****
{ TvglDragObject }
! constructor TvglDragObject.Create(aDragOrigin: TPoint);
begin
inherited Create;
DragOrigin := aDragOrigin;
CurPoint := DragOrigin;
end;
--- 1672,1688 ----
{ TvglDragObject }
! constructor TvglDragObject.Create(aFrom:TvglComponent; aDragOrigin: TPoint);
begin
inherited Create;
DragOrigin := aDragOrigin;
CurPoint := DragOrigin;
+ From := aFrom;
+ end;
+
+
+ destructor TvglDragObject.Destroy;
+ begin
+ inherited;
+ From := nil; // release from object
end;
***************
*** 1643,1647 ****
if assigned(FDragObj) then raise Exception.Create('TvglDragBox.doOnMouseDown: cannot drag more than once at a time!');
! FDragObj := TvglDragBroadcasterObject.Create(Point(X,Y));
FDragObj.OnDrag := DragHandler;
Manager.StartDrag(FDragObj);
--- 1728,1732 ----
if assigned(FDragObj) then raise Exception.Create('TvglDragBox.doOnMouseDown: cannot drag more than once at a time!');
! FDragObj := TvglDragBroadcasterObject.Create(Self,Point(X,Y));
FDragObj.OnDrag := DragHandler;
Manager.StartDrag(FDragObj);
***************
*** 1680,1687 ****
{ TvglDragCopyObject }
! constructor TvglDragCopyObject.Create(aDragOrigin: TPoint;
aCopyComponent: TvglComponent);
begin
! inherited Create(aDragOrigin);
CopyComponent := aCopyComponent;
end;
--- 1765,1772 ----
{ TvglDragCopyObject }
! constructor TvglDragCopyObject.Create(aFrom:TvglComponent; aDragOrigin: TPoint;
aCopyComponent: TvglComponent);
begin
! inherited Create(aFrom,aDragOrigin);
CopyComponent := aCopyComponent;
end;
***************
*** 1693,1697 ****
inherited;
if assigned(FDragObj) then FDragObj.Free;
! FDragObj := TvglDragCopyObject.Create(Point(x,y),self);
Manager.StartDrag(FDragObj);
end;
--- 1778,1782 ----
inherited;
if assigned(FDragObj) then FDragObj.Free;
! FDragObj := TvglDragCopyObject.Create(self,Point(x,y),self);
Manager.StartDrag(FDragObj);
end;
***************
*** 1722,1725 ****
--- 1807,1851 ----
CopyComponent.Bounds := b;
end;
+ end;
+
+ function TvglInterfaceManager.DragObjectOver(
+ component: TvglComponent): TvglDragObject;
+ var i:integer;
+ begin
+ // scan the drag objects to find if any of them intersect with this object
+ Result := nil;
+ for i := 0 to FDragObjects.Count-1 do
+ if PointInRectInAcc(component.Bounds,TvglDragObject(FDragObjects[i]).CurPoint.X,TvglDragObject(FDragObjects[i]).CurPoint.Y,0,0) then
+ Result := TvglDragObject(FDragObjects[i]);
+ end;
+
+ procedure TvglInterfaceManager.ReleaseDragObjects;
+ var i:integer;
+ begin
+ // end all drag objects
+ while FDragObjects.Count > 0 do
+ begin
+ EndDrag(TvglDragObject(FDragObjects[0]));
+ TvglDragObject(FDragObjects[0]).Free;
+ FDragObjects.Delete(0);
+ end;
+ end;
+
+ procedure TvglInterfaceManager.VGLAlert(msg: string);
+ var alert:TvglAlert;
+ begin
+ TraceString(' [mark 1] - VGLAlert');
+ alert := TvglAlert.Create('Alert',Desktop,msg);
+ TraceString(' [mark 2] - Created');
+ alert.OnClose := VGLAlertFree;
+ TraceString(' [mark 3] - about to show');
+ alert.Show;
+ TraceString(' [mark 4] - shown');
+ end;
+
+ procedure TvglInterfaceManager.VGLAlertFree(Sender: TObject);
+ begin
+ TraceString('[destroy]');
+ //TvglAlert(sender).Release; // WARNING: SEVERE BUG HERE!!!!
end;
Index: vglEdits.pas
===================================================================
RCS file: /cvsroot/pythianproject/Prototypes/GUISystem/vglEdits.pas,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** vglEdits.pas 2000/12/17 21:03:00 1.2
--- vglEdits.pas 2001/01/06 19:52:48 1.3
***************
*** 399,402 ****
--- 399,403 ----
Cnt, a, i: Integer;
begin
+ Result := -1;
if not PointInRect(where, X, Y) then
Exit;
Index: vglStdCtrls.pas
===================================================================
RCS file: /cvsroot/pythianproject/Prototypes/GUISystem/vglStdCtrls.pas,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -r1.9 -r1.10
*** vglStdCtrls.pas 2001/01/02 21:46:20 1.9
--- vglStdCtrls.pas 2001/01/06 19:52:48 1.10
***************
*** 6,10 ****
--- 6,14 ----
- Michael Hearn (mh...@su...)
+ To do:
+ * true word wrapping in TvglTextbox
+
Notes:
+ * Added TvglAlert + enhanced text box 6th January 2001
* Changed scrollbar to use skins - 11th December 2000
* Changed listbox to use one TGLText object for increased efficiency,
***************
*** 32,36 ****
interface
! uses Windows, GLCanvas, Classes, vglClasses, Graphics, SysUtils;
const
--- 36,40 ----
interface
! uses Windows, GLCanvas, Classes, vglClasses, Graphics, SysUtils{, Trace};
const
***************
*** 40,43 ****
--- 44,48 ----
VGL_SKINRECT_SCROLLBUTTON_DOWN :TRect = (Left:59;Top:183;Right:72;Bottom:202);
VGL_SKINRECT_SCROLL_TAB :TRect = (Left:93;Top:188;Right:119;Bottom:201);
+ VGL_SKINRECT_BUTTON :TRect = (Left:3;Top:3;Right:153;Bottom:48);
VGL_SKINRECT_CHECKBOXSET: TRect = (Left: 3; Top: 208; Right: 16; Bottom: 220);
***************
*** 288,304 ****
TvglTextBox = class(TvglComponent)
- private
- function GetFont: string;
- procedure SetFont(const Value: string);
- procedure SetColor(const Value: TColor);
protected
FText :TGLText;
function GetCaption: string;
procedure SetCaption(const Value: string);
function GetComponentType:string; override ;
function GetLines: TStringList;
procedure LinesOnChange(Sender:TObject);
procedure UpdateBounds;
public
property Lines:TStringList read GetLines;
--- 293,311 ----
TvglTextBox = class(TvglComponent)
protected
FText :TGLText;
+ FAutoSize :boolean;
+ FProcessing :boolean; // used to flag that we should ignore line changes for a while
function GetCaption: string;
procedure SetCaption(const Value: string);
function GetComponentType:string; override ;
function GetLines: TStringList;
+ function GetFont: string;
+ procedure SetFont(const Value: string);
+ procedure SetColor(const Value: TColor);
procedure LinesOnChange(Sender:TObject);
procedure UpdateBounds;
+ procedure DrawSelf(where:TRect); override ;
public
property Lines:TStringList read GetLines;
***************
*** 306,313 ****
property Font :string read GetFont write SetFont;
property Color :TColor write SetColor;
constructor Create(aName:string; aOwner:TVGLComponent);
destructor Destroy; override ;
! procedure DrawSelf(where:TRect); override ;
end;
--- 313,321 ----
property Font :string read GetFont write SetFont;
property Color :TColor write SetColor;
+ property AutoSize :boolean read FAutoSize write FAutoSize;
constructor Create(aName:string; aOwner:TVGLComponent);
destructor Destroy; override ;
! procedure WordWrap; // forces text to fit to bounds as much as possible
end;
***************
*** 339,342 ****
--- 347,372 ----
end;
+ TvglAlert = class(TvglComponent)
+ protected
+ FAlertResult: integer;
+ FBoxBounds :TRect;
+ FImage :TGLBitmap;
+ FOKButton :TvglButton;
+ FTextBox :TvglTextBox;
+ FOnClose: TNotifyEvent;
+ function GetComponentType:string; override ;
+ procedure OKOnClick(Sender:TObject);
+ public
+ property MessageTextBox :TvglTextBox read FTextBox;
+ property AlertResult :integer read FAlertResult;
+ property OnClose :TNotifyEvent read FOnClose write FOnClose;
+
+ constructor Create(aName:string; AOwner:TvglComponent; Msg:string);
+ destructor Destroy; override ;
+ procedure Show;
+ procedure DrawSelf(where:TRect); override ;
+ end;
+
+
implementation
uses
***************
*** 1553,1559 ****
--- 1583,1591 ----
begin
inherited Create(aName,aOwner);
+ FAutoSize := true;
FText := TGLText.Create('Arial');
FText.Precache := true;
FText.Lines.OnChange := LinesOnChange;
+ FProcessing := false;
end;
***************
*** 1567,1570 ****
--- 1599,1604 ----
begin
inherited DrawSelf(where);
+ // CLIP
+ Canvas.SetClipping(where);
Canvas.DrawText(where.Left,where.Top,FText);
end;
***************
*** 1594,1598 ****
// update bounds
FText.LinesOnChange(Sender); //call text handler to prevent overriding
! UpdateBounds;
end;
--- 1628,1633 ----
// update bounds
FText.LinesOnChange(Sender); //call text handler to prevent overriding
! if not FProcessing then
! UpdateBounds;
end;
***************
*** 1617,1628 ****
longest:integer;
begin
! // locate longest line
! longest := 0;
! for i := 0 to FText.Lines.Count-1 do
! if FText.Width[i] > longest then longest := FText.Width[i];
! Width := longest;
! Height := FText.Lines.Count*FText.QT.GridSquareHeight;
end;
{ TvglEdit }
--- 1652,1703 ----
longest:integer;
begin
! if FAutoSize then
! begin
! longest := 0;
! for i := 0 to FText.Lines.Count-1 do
! if FText.Width[i] > longest then longest := FText.Width[i];
! Width := longest;
! Height := FText.Lines.Count*FText.QT.GridSquareHeight;
! end;
end;
+ procedure TvglTextBox.WordWrap;
+ var
+ i,j:integer;
+ s,r:string;
+ begin
+ i := 0;
+ FProcessing := true;
+ while i < FText.Lines.Count do
+ begin
+ //TraceString('scanning line: '+FText.Lines[i]+' ['+IntToStr(FText.Width[i])+'/'+IntToStr(Width)+']');
+ if FText.Width[i] > Width-5 then { 5 is a tolerance value, increase to reduce chance of letter clipping }
+ begin
+ // we need to locate where the line needs breaking
+ //TraceString('line '+IntToStr(i)+' needs breaking: '+FText.Lines[i]);
+ s := '';
+ for j := 1 to Length(FText.Lines[i]) do
+ begin
+ s := s + FText.Lines[i][j];
+ if qtGetStringWidth(FText.QT,s) >= Width then
+ begin
+ // break the line here
+ r := Copy(FText.Lines[i],j+1,Length(FText.Lines[i])); // r now has the rest of the line in
+ //TraceString(' line '+IntToStr(i)+' replaced with '+s);
+ FText.Lines[i] := s;
+ if i+1 = FText.Lines.Count then
+ FText.Lines.Add(trim(r))
+ else FText.Lines.Insert(i+1,trim(r));
+ //TraceString(' [inserted at '+IntToStr(i+1)+']'+r);
+ break;
+ end;
+ end;
+ end;
+ inc(i);
+ end;
+ if AutoSize then Height := FText.Lines.Count*FText.QT.GridSquareHeight; // make correct height
+ FProcessing := false;
+ end;
+
{ TvglEdit }
***************
*** 1721,1724 ****
--- 1796,1877 ----
if CursorY > FLines.Count then CursorY := FLines.Count;
if CursorX > Length(Flines[CursorY-1]) then CursorX := Length(Flines[CursorY-1]);
+ end;
+
+ { TvglAlert }
+
+ constructor TvglAlert.Create(aName: string; AOwner: TvglComponent; Msg:string);
+ var ALERT_WIDTH :integer;
+ ALERT_HEIGHT :integer;
+ begin
+ inherited Create(aName,aOwner);
+ ALERT_WIDTH := 300;
+ Visible := false;
+ FBounds := Manager.Desktop.Bounds;
+ FAlertResult := -1;
+ FImage := TGLBitmap(Manager.GetResource(VGL_SKIN_1));
+
+ ALERT_HEIGHT := 100; //FTextBox.Height + 10 + (VGL_SKINRECT_BUTTON.Bottom-VGL_SKINRECT_BUTTON.Top);
+ FBoxBounds := Rect(Manager.ScreenBounds.Right div 2 - (ALERT_WIDTH div 2),Manager.ScreenBounds.Bottom div 2 - (ALERT_HEIGHT div 2),Manager.ScreenBounds.Right div 2 + (ALERT_WIDTH div 2),Manager.ScreenBounds.Bottom div 2 + (ALERT_HEIGHT div 2));
+
+ FOKButton := TvglButton.Create('vglAlert_OKButton',Self);
+ FOKButton.Caption := '|O|K';
+ FOKButton.HotKey := Ord('O');
+ FOKButton.HasHotkey := true;
+ FOKButton.Bounds := Rect((Width div 2) - (VGL_SKINRECT_BUTTON.Right-VGL_SKINRECT_BUTTON.Left) div 2,FBoxBounds.Bottom - 5 - (VGL_SKINRECT_BUTTON.Bottom-VGL_SKINRECT_BUTTON.Top),0,0);
+ FOKButton.OnClick := OKOnClick;
+
+ FTextBox := TvglTextbox.Create('vglAlert_TextBox',Self);
+ FTextBox.AutoSize := false;
+ FTextBox.Bounds := Rect(FBoxBounds.Left+10,FBoxBounds.Top+10,FBoxBounds.Right-10,FBoxBounds.Bottom-FOKButton.Height-10);
+ FTextbox.Lines.Text := msg;
+ FTextBox.Color := clBlack;
+ //tracestring('* height before = '+inttostr(Ftextbox.height));
+ FTextBox.AutoSize := true;
+ FTextBox.WordWrap;
+ //tracestring('* height after = '+inttostr(Ftextbox.height));
+ //tracestring('* text after = '+ftextbox.lines.text);
+ // recalculate
+ ALERT_HEIGHT := 20 + FOKButton.Height + FTextBox.Height;
+ FBoxBounds := Rect(Manager.ScreenBounds.Right div 2 - (ALERT_WIDTH div 2),Manager.ScreenBounds.Bottom div 2 - (ALERT_HEIGHT div 2),Manager.ScreenBounds.Right div 2 + (ALERT_WIDTH div 2),Manager.ScreenBounds.Bottom div 2 + (ALERT_HEIGHT div 2));
+ FOKButton.Bounds := Rect((Width div 2) - (VGL_SKINRECT_BUTTON.Right-VGL_SKINRECT_BUTTON.Left) div 2,FBoxBounds.Bottom - 5 - (VGL_SKINRECT_BUTTON.Bottom-VGL_SKINRECT_BUTTON.Top),0,0);
+ FTextBox.Bounds := Rect(FBoxBounds.Left+10,FBoxBounds.Top+10,FBoxBounds.Right-10,FBoxBounds.Bottom-FOKButton.Height-10);
+ end;
+
+ destructor TvglAlert.Destroy;
+ begin
+ FImage := nil;
+ inherited;
+ end;
+
+ procedure TvglAlert.DrawSelf(where: TRect);
+ begin
+ inherited DrawSelf(where);
+ where := FBoxBounds;
+ // draw backpanel
+ Canvas.CurrentColor := clBlack;
+ Canvas.FillAlpha := 0.5;
+ Canvas.Rectangle(Manager.Desktop.ScreenBounds);
+ // draw "window"
+ Canvas.ImageAlpha := TotalAlpha;
+ Canvas.TileBitmapSubRect(where,VGL_SKINRECT_BACKGROUND,FImage);
+ Manager.DrawBorder(where,FImage);
+ end;
+
+ function TvglAlert.GetComponentType: string;
+ begin
+ Result := 'Alert';
+ end;
+
+ procedure TvglAlert.OKOnClick(Sender: TObject);
+ begin
+ // user wants to cancel alert so tidy up
+ FAlertResult := 0;
+ Visible := false;
+ if assigned(FOnClose) then FOnClose(self);
+ end;
+
+ procedure TvglAlert.Show;
+ begin
+ Visible := true;
end;
|
