paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-27 00:23:53 +02:00
Code Issues Packages Projects Releases Wiki Activity
4d2b332a14
lazarus/lcl/forms.pp
lazarus 4d2b332a14 MG: improved TScreen and ShowModal 
git-svn-id: trunk@3306 -
2002-09-09 14:01:05 +00:00

576 lines
19 KiB
ObjectPascal
Raw Blame History

{
/***************************************************************************
forms.pp
--------
Component Library Code
Initial Revision : Sun Mar 28 23:15:32 CST 1999
Revised : Sat Jul 15 1999
***************************************************************************/
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.LCL, included in this distribution, *
* for details about the copyright. *
* *
* 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. *
* *
*****************************************************************************
}
unit Forms;
{$mode objfpc}{$H+}
interface
{$ifdef Trace}
{$ASSERTIONS ON}
{$endif}
uses
Classes, Controls, VCLGlobals, SysUtils, GraphType, Graphics, Menus,
LCLLinux, LCLType, LMessages;
type
TPosition = (poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly,
poScreenCenter, poDesktopCenter, poMainFormCenter, poOwnerFormCenter);
TWindowState = (wsNormal, wsMinimized, wsMaximized);
TCloseAction = (caNone, caHide, caFree, caMinimize);
TScrollBarKind = (sbHorizontal, sbVertical);
TScrollBarInc = 1..32768;
TScrollBarStyle = (ssRegular, ssFlat, ssHotTrack);
TControlScrollBar = class(TPersistent)
end;
TScrollingWinControl = class(TWinControl)
private
//FHorzScrollBar : TControlScrollBar;
//FVertScrollBar : TControlScrollBar;
//FAutoScroll : Boolean;
end;
TIDesigner = class;
TCloseEvent = procedure(Sender: TObject; var Action: TCloseAction) of object;
TCloseQueryEvent = procedure(Sender : TObject; var CanClose : boolean) of object;
TFormState = set of (fsCreating, fsVisible, fsShowing, fsModal, fsCreatedMDIChild);
TModalResult = low(Integer)..high(Integer);
TCustomForm = class(TWinControl)
private
FActive : Boolean;
FActiveControl : TWinControl;
FBorderStyle : TFormBorderStyle;
FCanvas : TControlCanvas;
FDesigner : TIDesigner;
FFormStyle : TFormStyle;
FFormState: TFormState;
FIcon: TIcon;
FKeyPreview: Boolean;
FMenu : TMainMenu;
FModalResult : TModalResult;
FOnActivate: TNotifyEvent;
FOnCreate: TNotifyEvent;
FOnDeactivate : TNotifyEvent;
FOnDestroy: TNotifyEvent;
FOnHide: TNotifyEvent;
FOnShow: TNotifyEvent;
FOnPaint: TNotifyEvent;
FOnClose: TCloseEvent;
FOnCloseQuery : TCloseQueryEvent;
FPosition : TPosition;
FWindowState : TWindowState;
procedure ClientWndProc(var Message: TLMessage);
procedure CloseModal;
procedure DoCreate;
procedure DoDestroy;
procedure SetActiveControl(Value : TWinControl);
procedure SetBorderStyle(Value : TFORMBorderStyle);
procedure SetDesigner(Value : TIDesigner);
procedure SetMenu(Value : TMainMenu);
procedure SetFormStyle(Value : TFormStyle);
procedure SetIcon(AValue: TIcon);
procedure SetPosition(Value : TPosition);
procedure SetVisible(Value: boolean);
procedure SetWindowState(Value : TWIndowState);
function GetCanvas: TControlCanvas;
function IsForm : Boolean;
procedure IconChanged(Sender: TObject);
function IsIconStored: Boolean;
{ events }
procedure WMActivate(var Message : TLMActivate); message LM_ACTIVATE;
procedure WMDeactivate(var Message : TLMActivate); message LM_DEACTIVATE;
procedure WMPaint(var message: TLMPaint); message LM_PAINT;
procedure WMSize(var message: TLMSize); message LM_Size;
procedure WMShowWindow(var message: TLMShowWindow); message LM_SHOWWINDOW;
procedure WMCloseQuery(var message: TLMessage); message LM_CLOSEQUERY;
procedure WMDestroy(var message: TLMDestroy); message LM_DESTROY;
protected
procedure Activate; dynamic;
function CloseQuery : boolean; virtual;
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure Deactivate;dynamic;
procedure DoClose(var Action: TCloseAction); dynamic;
procedure DoHide; dynamic;
procedure DoShow; dynamic;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
// Delphi needed GetClientRect for window specific things, LCL not
// Function GetClientRect : TRect ; Override;
procedure Notification(AComponent: TComponent; Operation : TOperation);override;
procedure Paint; dynamic;
procedure PaintWindow(dc : Hdc); override;
procedure RequestAlign; override;
procedure UpdateShowing; override;
procedure UpdateWindowState;
procedure ValidateRename(AComponent: TComponent;
const CurName, NewName: string);override;
procedure WndProc(var TheMessage : TLMessage); override;
{events}
property ActiveControl : TWinControl read FActiveControl write SetActiveControl;
property Icon: TIcon read FIcon write SetIcon stored IsIconStored;
property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
property OnClose: TCloseEvent read FOnClose write FOnClose stored IsForm;
property OnCloseQuery : TCloseQueryEvent
read FOnCloseQuery write FOnCloseQuery stored IsForm;
property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
property OnHide: TNotifyEvent read FOnHide write FOnHide;
property OnShow: TNotifyEvent read FOnShow write FOnShow;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
property OnResize stored IsForm;
property Position : TPosition read FPosition write SetPosition default poDesigned;
public
constructor Create(AOwner: TComponent); override;
constructor CreateNew(AOwner: TComponent; Num : Integer); virtual;
procedure BeforeDestruction; override;
function GetIconHandle: HICON;
destructor Destroy; override;
procedure Close;
procedure Hide;
function WantChildKey(Child : TControl; var MEssage : TLMessage): Boolean; virtual;
procedure SetFocus; override;
function SetFocusedControl(Control : TWinControl): Boolean ; Virtual;
procedure FocusControl(WinControl : TWinControl);
function ShowModal : Integer;
property Active : Boolean read FActive;
property BorderStyle : TFormBorderStyle
read FBorderStyle write SetBorderStyle default bsSizeable;
property Canvas: TControlCanvas read GetCanvas;
property Caption stored IsForm;
property Designer : TIDesigner read FDesigner write SetDesigner;
property FormStyle : TFormStyle read FFormStyle write SetFormStyle default fsNormal;
property FormState : TFormState read FFormState;
property KeyPreview: Boolean read FKeyPreview write FKeyPreview;
property Menu : TMainMenu read FMenu write SetMenu;
property ModalResult : TModalResult read FModalResult write FModalResult;
property Visible write SetVisible default False;
property WindowState: TWindowState read FWindowState write SetWindowState default wsNormal;
end;
TForm = class(TCustomForm)
private
FClientHandle: HWND;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property ClientHandle: HWND read FClientHandle;
published
property ActiveCOntrol;
property Align;
property AutoSize;
property BorderStyle;
property Caption;
property Color;
property ClientHeight;
property ClientWidth;
property Constraints;
property Enabled;
property FormStyle;
property Icon;
property Menu;
property PopupMenu;
property Position;
property ShowHint;
property Visible;
property WindowState;
property OnActivate;
property OnCreate;
property OnClose;
property OnCloseQuery;
property OnDeactivate;
property OnDestroy;
property OnShow;
property OnHide;
property OnPaint;
property OnResize;
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
FFocusedForm: TCustomForm;
FFormList: TList;
FHintFont : TFont;
FPixelsPerInch : integer;
FSaveFocusedList: TList;
function GetFormCount: Integer;
function GetForms(IIndex: Integer): TForm;
function GetHeight : Integer;
function GetWidth : Integer;
procedure AddForm(FForm: TCustomForm);
procedure RemoveForm(FForm: TCustomForm);
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; Override;
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;
TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object;
TApplication = class(TComponent)
private
FHandle : THandle;
FIcon: TIcon;
FList: TList;
FMainForm : TForm;
FMouseControl: TControl;
FOnException: TExceptionEvent;
FOnIdle: TIdleEvent;
FTerminate : Boolean;
// MWE:Do we need this ??
// function ProcessMessage(Var Msg : TMsg) : Boolean;
procedure wndproc(var Message : TLMessage);
// Shane: the following is used for Messagebox button clicks. Temporary until I figure out a better way.
procedure DefaultOnClick(Sender : TObject);
//----
function GetExename: String;
function GetIconHandle: HICON;
function GetTitle: string;
procedure IconChanged(Sender: TObject);
procedure Idle;
procedure MouseIdle(const CurrentControl: TControl);
procedure SetIcon(AValue: TIcon);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ControlDestroyed(AControl: TControl);
Procedure BringToFront;
procedure CreateForm(NewForm : TFormClass; var ref);
procedure HandleException(Sender: TObject);
procedure HandleMessage;
procedure HintMouseMEssage(Control : TControl; var Message: TLMessage);
property Icon: TIcon read FIcon write SetIcon;
procedure Initialize;
function MessageBox(Text, Caption : PChar; Flags : Longint) : Integer;
procedure Notification(AComponent : TComponent; Operation : TOperation); override;
Procedure ProcessMessages;
procedure Run;
procedure ShowException(E: Exception);
procedure Terminate;
property Exename: String read GetExeName;
property Handle: THandle read FHandle;
property Terminated: Boolean read FTerminate;
property MainForm: TForm read FMainForm;
property OnException: TExceptionEvent read FOnException write FOnException;
property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
end;
TIDesigner = class(TObject)
public
function IsDesignMsg(Sender: TControl; var Message: TLMessage): Boolean;
virtual; abstract;
procedure Modified; virtual; abstract;
procedure Notification(AComponent: TComponent;
Operation: TOperation); virtual; abstract;
procedure PaintGrid; virtual; abstract;
procedure ValidateRename(AComponent: TComponent;
const CurName, NewName: string); virtual; abstract;
function GetShiftState: TShiftState; virtual; abstract;
Procedure SelectOnlyThisComponent(AComponent:TComponent); virtual; abstract;
end;
TProcedure = procedure;
function KeysToShiftState(Keys:Word): TShiftState;
function KeyDataToShiftState(KeyData: Longint): TShiftState;
type
TFocusState = type Pointer;
function SaveFocusState: TFocusState;
procedure RestoreFocusState(FocusState: TFocusState);
function GetParentForm(Control:TControl): TCustomForm;
function FindRootDesigner(AComponent: TComponent): TIDesigner;
function IsAccel(VK : Word; const Str : ShortString): Boolean;
function InitResourceComponent(Instance: TComponent; RootAncestor: TClass):Boolean;
var
Application : TApplication;
Screen : TScreen;
ExceptionObject : TExceptObject;
implementation
uses
Buttons, StdCtrls, Interfaces, LResources, dialogs,ExtCtrls {,designer};
const
FocusMessages : Boolean = true;
FocusCount: Integer = 0;
//------------------------------------------------------------------------------
procedure ExceptionOccurred(Sender : TObject; Addr,Frame : Pointer);
var
Mess : String;
Begin
Writeln('[FORMS.PP] ExceptionOccurred Procedure');
Mess := 'Error occurred in '+Sender.ClassName+' at '#13#10'Address '+HexStr(Cardinal(Addr),8)+#13#10'Frame '+HexStr(Cardinal(Frame),8);
if Application<>nil then
Application.MessageBox(PChar(Mess),'Exception',mb_IconError+mb_Ok)
else
writeln(Mess);
end;
//------------------------------------------------------------------------------
// The focus state is just the focus count for now. To save having to allocate
// anything, I just map the Integer to the TFocusState.
function SaveFocusState: TFocusState;
begin
Result := TFocusState(FocusCount);
end;
procedure RestoreFocusState(FocusState: TFocusState);
begin
FocusCount := Integer(FocusState);
end;
function SendFocusMessage(Window: HWnd; Msg: Word): Boolean;
var
Count: Integer;
begin
Count := FocusCount;
SendMessage(Window, Msg, 0, 0);
Result := (FocusCount = Count);
end;
//------------------------------------------------------------------------------
function KeysToShiftState(Keys:Word): TShiftState;
begin
Result := [];
if Keys and MK_Shift <> 0 then Include(Result,ssShift);
if Keys and MK_Control <> 0 then Include(Result,ssCtrl);
if Keys and MK_LButton <> 0 then Include(Result,ssLeft);
if Keys and MK_RButton <> 0 then Include(Result,ssRight);
if Keys and MK_MButton <> 0 then Include(Result,ssMiddle);
if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
end;
function KeyDataToShiftState(KeyData: Longint): TShiftState;
begin
Result := [];
if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift);
if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl);
if KeyData and $20000000 <> 0 then Include(Result, ssAlt);
end;
//------------------------------------------------------------------------------
function GetParentForm(Control:TControl): TCustomForm;
begin
while Control.Parent <> nil do
Control := Control.Parent;
if Control is TCustomForm
then Result := TCustomForm(Control)
else Result := nil;
end;
//------------------------------------------------------------------------------
function IsAccel(VK : Word; const Str : ShortString): Boolean;
begin
Result := true;
end;
//==============================================================================
function InitResourceComponent(Instance: TComponent;
RootAncestor: TClass):Boolean;
function InitComponent(ClassType: TClass): Boolean;
procedure ApplyVisible;
var
i: integer;
AControl: TControl;
begin
// The LCL has as default Visible=false. But for Delphi compatbility
// loading control defaults to true.
if Instance is TControl then
for i:=0 to Instance.ComponentCount-1 do begin
AControl:=TControl(Instance.Components[i]);
if (AControl is TControl) then begin
if (not (csVisibleSetInLoading in AControl.ControlState)) then
AControl.Visible:=true
else
AControl.ControlState:=
AControl.ControlState-[csVisibleSetInLoading];
end;
end;
end;
var
CompResource:TLResource;
MemStream: TMemoryStream;
begin
//writeln('[InitComponent] ',ClassType.Classname,' ',Instance<>nil);
Result:=false;
if (ClassType=TComponent) or (ClassType=RootAncestor) then exit;
if Assigned(ClassType.ClassParent) then
Result:=InitComponent(ClassType.ClassParent);
CompResource:=LazarusResources.Find(ClassType.ClassName);
if (CompResource = nil) or (CompResource.Value='') then exit;
//writeln('[InitComponent] CompResource found for ',ClassType.Classname);
if (ClassType.InheritsFrom(TForm))
and (CompResource.ValueType<>'FORMDATA') then exit;
MemStream:=TMemoryStream.Create;
try
MemStream.Write(CompResource.Value[1],length(CompResource.Value));
MemStream.Position:=0;
writeln('Form Stream "',ClassType.ClassName,'" Signature=',copy(CompResource.Value,1,4));
try
Instance:=MemStream.ReadComponent(Instance);
except
on E: Exception do begin
writeln('Form streaming "',ClassType.ClassName,'" error: ',E.Message);
exit;
end;
end;
finally
ApplyVisible;
MemStream.Free;
end;
Result:=true;
end;
// InitResourceComponent
//var LocalizedLoading: Boolean;
begin
//GlobalNameSpace.BeginWrite; // hold lock across all ancestor loads (performance)
try
//LocalizedLoading:=(Instance.ComponentState * [csInline,csLoading])=[];
//if LocalizedLoading then BeginGloabelLoading; // push new loadlist onto stack
try
Result:=InitComponent(Instance.ClassType);
//if LocalizedLoading then NotifyGloablLoading; // call Loaded
finally
//if LocalizedLoading then EndGloablLoading; // pop loadlist off stack
end;
finally
//GlobalNameSpace.EndWrite;
end;
end;
function FindRootDesigner(AComponent: TComponent): TIDesigner;
var
Form: TCustomForm;
begin
Result:=nil;
if AComponent=nil then exit;
while (AComponent<>nil) do begin
if (AComponent is TCustomForm) then begin
Form:=TCustomForm(AComponent);
if Form.Parent=nil then begin
Result:=Form.Designer;
exit;
end;
end;
if AComponent is TControl then begin
AComponent:=TControl(AComponent).Parent;
end else begin
exit;
end;
end;
end;
//==============================================================================
{$I form.inc}
{$I customform.inc}
{$I screen.inc}
{$I application.inc}
{$I hintwindow.inc}
initialization
Screen:= TScreen.Create(nil);
Application:= TApplication.Create(nil);
Focusmessages := True;
finalization
writeln('forms.pp - finalization section');
Application.Free;
Application:= nil;
Screen.Free;
Screen:= nil;
end.
Reference in New Issue View Git Blame Copy Permalink