source: trunk/Packages/DpiControls/Dpi.Forms.pas

Last change on this file was 500, checked in by chronos, 7 months ago
  • Fixed: Application memory leak.
File size: 27.2 KB
Line 
1unit Dpi.Forms;
2
3interface
4
5uses
6 Classes, SysUtils, Forms, LMessages, Controls, LCLType,
7 Generics.Collections, LCLProc, LResources, Graphics, Dpi.Controls,
8 Dpi.Graphics;
9
10const
11 crDefault = TCursor(0);
12
13type
14 TMessageEvent = procedure (var TheMessage : TLMessage) of object;
15 TCloseAction = Forms.TCloseAction;
16 TFormState = Forms.TFormState;
17 TFormStateType = Forms.TFormStateType;
18 TWindowState = Forms.TWindowState;
19 TScrollBarKind = Forms.TScrollBarKind;
20 TBorderIcon = Forms.TBorderIcon;
21 TShowInTaskbar = Forms.TShowInTaskbar;
22 TTaskBarBehavior = Forms.TTaskBarBehavior;
23
24 { TFormEx }
25
26 TFormEx = class(Forms.TForm)
27 private
28 FOnMessage: TMessageEvent;
29 protected
30 procedure WndProc(var TheMessage : TLMessage); override;
31 property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
32 end;
33
34 { TControlScrollBar }
35
36 TControlScrollBar = class(TPersistent)
37 private
38 function GetVisible: Boolean;
39 procedure SetVisible(AValue: Boolean);
40 published
41 property Visible: Boolean read GetVisible write SetVisible;
42 end;
43
44 { TScrollingWinControl }
45
46 TScrollingWinControl = class(TCustomControl)
47 private
48 FHorzScrollBar: TControlScrollBar;
49 FVertScrollBar: TControlScrollBar;
50 protected
51 function GetNativeCustomControl: Controls.TCustomControl; override;
52 function GetNativeScrollingWinControl: Forms.TScrollingWinControl; virtual;
53 public
54 constructor Create(TheOwner: TComponent); override;
55 destructor Destroy; override;
56 published
57 property HorzScrollBar: TControlScrollBar read FHorzScrollBar write FHorzScrollBar;
58 property VertScrollBar: TControlScrollBar read FVertScrollBar write FVertScrollBar;
59 end;
60
61 { TForm }
62
63 TForm = class(TScrollingWinControl)
64 private
65 FOnActivate: TNotifyEvent;
66 FOnClose: TCloseEvent;
67 FOnCloseQuery: TCloseQueryEvent;
68 FOnDeactivate: TNotifyEvent;
69 function GetBorderIcons: TBorderIcons;
70 function GetBorderStyle: TFormBorderStyle;
71 function GetDesignTimePPI: Integer;
72 function GetFormState: TFormState;
73 function GetFormStyle: TFormStyle;
74 function GetKeyPreview: Boolean;
75 function GetLCLVersion: string;
76 function GetModalResult: TModalResult;
77 function GetOnCloseQuery: TCloseQueryEvent;
78 function GetOnCreate: TNotifyEvent;
79 function GetOnDeactivate: TNotifyEvent;
80 function GetOnDestroy: TNotifyEvent;
81 function GetOnHide: TNotifyEvent;
82 function GetOnShow: TNotifyEvent;
83 function GetPosition: TPosition;
84 function GetRestoredHeight: Integer;
85 function GetRestoredLeft: Integer;
86 function GetRestoredTop: Integer;
87 function GetRestoredWidth: Integer;
88 function GetShowInTaskbar: TShowInTaskbar;
89 function GetWindowState: TWindowState;
90 procedure SetBorderIcons(AValue: TBorderIcons);
91 procedure SetBorderStyle(AValue: TFormBorderStyle);
92 procedure SetDesignTimePPI(AValue: Integer);
93 procedure SetFormStyle(AValue: TFormStyle);
94 procedure SetKeyPreview(AValue: Boolean);
95 procedure SetLCLVersion(AValue: string);
96 procedure SetModalResult(AValue: TModalResult);
97 procedure SetOnCloseQuery(AValue: TCloseQueryEvent);
98 procedure SetOnCreate(AValue: TNotifyEvent);
99 procedure SetOnDeactivate(AValue: TNotifyEvent);
100 procedure SetOnDestroy(AValue: TNotifyEvent);
101 procedure SetOnHide(AValue: TNotifyEvent);
102 procedure SetOnShow(AValue: TNotifyEvent);
103 procedure DoOnCreate;
104 procedure FormMessageHandler(var TheMessage: TLMessage);
105 procedure SetPosition(AValue: TPosition);
106 procedure SetShowInTaskBar(AValue: TShowInTaskbar);
107 procedure SetWindowState(AValue: TWindowState);
108 procedure ActivateHandler(Sender: TObject);
109 procedure DeactivateHandler(Sender: TObject);
110 procedure DoClose(var CloseAction: TCloseAction); virtual;
111 procedure CloseHandler(Sender: TObject; var CloseAction: TCloseAction);
112 procedure CloseQueryHandler(Sender : TObject; var CanClose : boolean);
113 protected
114 procedure CreateParams(var p: TCreateParams); virtual;
115 procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
116 function GetNativeScrollingWinControl: Forms.TScrollingWinControl; override;
117 function GetNativeForm: Forms.TForm; virtual;
118 procedure UpdateNativeControl; override;
119 public
120 NativeForm: Forms.TForm;
121 procedure AfterConstruction; override;
122 property ModalResult: TModalResult read GetModalResult write SetModalResult;
123 function ShowModal: Integer; virtual;
124 procedure SetFocus; override;
125 procedure Close;
126 function CloseQuery: boolean; virtual;
127 procedure BringToFront;
128 procedure Release;
129 constructor Create(TheOwner: TComponent); override;
130 constructor CreateNew(AOwner: TComponent; Num: Integer = 0); virtual;
131 destructor Destroy; override;
132 published
133 property RestoredLeft: integer read GetRestoredLeft;
134 property RestoredTop: integer read GetRestoredTop;
135 property RestoredWidth: integer read GetRestoredWidth;
136 property RestoredHeight: integer read GetRestoredHeight;
137 property DesignTimePPI: Integer read GetDesignTimePPI write SetDesignTimePPI; // Not used
138 property FormState: TFormState read GetFormState;
139 property FormStyle: TFormStyle read GetFormStyle write SetFormStyle;
140 property BorderStyle: TFormBorderStyle read GetBorderStyle write SetBorderStyle default bsSizeable;
141 property BorderIcons: TBorderIcons read GetBorderIcons write SetBorderIcons;
142 property LCLVersion: string read GetLCLVersion write SetLCLVersion;
143 property KeyPreview: Boolean read GetKeyPreview write SetKeyPreview default False;
144 property Position: TPosition read GetPosition write SetPosition default poDesigned;
145 property WindowState: TWindowState read GetWindowState write SetWindowState default wsNormal;
146 property OnShow: TNotifyEvent read GetOnShow write SetOnShow;
147 property OnHide: TNotifyEvent read GetOnHide write SetOnHide;
148 property OnCreate: TNotifyEvent read GetOnCreate write SetOnCreate;
149 property OnDestroy: TNotifyEvent read GetOnDestroy write SetOnDestroy;
150 property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
151 property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
152 property OnClose: TCloseEvent read FOnClose write FOnClose;
153 property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery;
154 property ClientHeight;
155 property ClientWidth;
156 property OnMouseUp;
157 property OnMouseDown;
158 property OnMouseMove;
159 property ShowInTaskBar: TShowInTaskbar read GetShowInTaskbar write SetShowInTaskBar
160 default stDefault;
161 end;
162
163 TForms = TObjectList<TForm>;
164
165 { TApplication }
166
167 TApplication = class(TComponent)
168 private
169 FMainForm: TForm;
170 FCreatingForm: TForm;
171 function GetActive: Boolean;
172 function GetExeName: string;
173 function GetShowMainForm: Boolean;
174 function GetTaskBarBehavior: TTaskBarBehavior;
175 function GetTitle: string;
176 procedure SetMainForm(AValue: TForm);
177 function GetMainForm: TForm;
178 procedure SetShowMainForm(AValue: Boolean);
179 procedure SetTaskBarBehavior(AValue: TTaskBarBehavior);
180 procedure SetTitle(AValue: string);
181 protected
182 function GetNativeApplication: Forms.TApplication; virtual;
183 procedure DoBeforeFinalization;
184 public
185 constructor Create(AOwner: TComponent); override;
186 destructor Destroy; override;
187 procedure Run;
188 procedure Initialize;
189 procedure Terminate;
190 procedure ProcessMessages;
191 procedure UpdateMainForm(AForm: TForm);
192 procedure CreateForm(InstanceClass: TComponentClass; out Reference);
193 procedure RemoveStayOnTop(const ASystemTopAlso: Boolean = False);
194 procedure RestoreStayOnTop(const ASystemTopAlso: Boolean = False);
195 function MessageBox(Text, Caption: PChar; Flags: Longint = MB_OK): Integer;
196 property MainForm: TForm read GetMainForm write SetMainForm;
197 property ShowMainForm: Boolean read GetShowMainForm write SetShowMainForm default True;
198 property Title: string read GetTitle write SetTitle;
199 property Active: Boolean read GetActive;
200 property ExeName: string read GetExeName;
201 property TaskBarBehavior: TTaskBarBehavior read GetTaskBarBehavior write SetTaskBarBehavior;
202 end;
203
204 { TScreen }
205
206 TScreen = class
207 private
208 FDpi: Integer;
209 FActiveForm: TForm;
210 FPrevActiveForms: TForms;
211 FForms: TForms;
212 procedure AddForm(AForm: TForm);
213 function GetDesktopHeight: Integer;
214 function GetDesktopLeft: Integer;
215 function GetDesktopTop: Integer;
216 function GetDesktopWidth: Integer;
217 procedure RemoveForm(AForm: TForm);
218 function GetActiveForm: TForm;
219 function GetCursor: TCursor;
220 function GetCursors(Index: Integer): HCURSOR;
221 function GetFormCount: Integer;
222 function GetForms(Index: Integer): TForm;
223 function GetHeight: Integer;
224 function GetWidth: Integer;
225 procedure SetCursor(AValue: TCursor);
226 procedure SetCursors(Index: Integer; AValue: HCURSOR);
227 procedure SetDpi(AValue: Integer);
228 procedure UpdateForms;
229 public
230 constructor Create;
231 destructor Destroy; override;
232 procedure UpdateActiveFormFromNativeScreen;
233 function DisableForms(SkipForm: TForm; DisabledList: Classes.TList = nil): Classes.TList;
234 procedure EnableForms(var AFormList: Classes.TList);
235 function GetSystemDpi: Integer;
236 property FormCount: Integer read GetFormCount;
237 property Forms[Index: Integer]: TForm read GetForms;
238 property ActiveForm: TForm read GetActiveForm;
239 property Cursor: TCursor read GetCursor write SetCursor;
240 property Cursors[Index: Integer]: HCURSOR read GetCursors write SetCursors;
241 published
242 property Dpi: Integer read FDpi write SetDpi;
243 property PixelsPerInch: Integer read FDpi;
244 property Width: Integer read GetWidth;
245 property Height: Integer read GetHeight;
246 property DesktopLeft: Integer read GetDesktopLeft;
247 property DesktopTop: Integer read GetDesktopTop;
248 property DesktopWidth: Integer read GetDesktopWidth;
249 property DesktopHeight: Integer read GetDesktopHeight;
250 end;
251
252var
253 Application: TApplication;
254 Screen: TScreen;
255
256
257implementation
258
259uses
260 Dpi.Common;
261
262var
263 LCLScreen: Forms.TScreen absolute Forms.Screen;
264
265{ TFormEx }
266
267procedure TFormEx.WndProc(var TheMessage: TLMessage);
268begin
269 inherited WndProc(TheMessage);
270 if Assigned(FOnMessage) then
271 FOnMessage(TheMessage);
272end;
273
274{ TScrollingWinControl }
275
276function TScrollingWinControl.GetNativeCustomControl: Controls.TCustomControl;
277begin
278 Result := GetNativeScrollingWinControl;
279end;
280
281function TScrollingWinControl.GetNativeScrollingWinControl: Forms.TScrollingWinControl;
282begin
283 Result := nil;
284end;
285
286constructor TScrollingWinControl.Create(TheOwner: TComponent);
287begin
288 inherited;
289 FHorzScrollBar := TControlScrollBar.Create;
290 FVertScrollBar := TControlScrollBar.Create;
291end;
292
293destructor TScrollingWinControl.Destroy;
294begin
295 FreeAndNil(FHorzScrollBar);
296 FreeAndNil(FVertScrollBar);
297 inherited;
298end;
299
300{ TApplication }
301
302procedure TApplication.SetMainForm(AValue: TForm);
303begin
304 FMainForm := AValue;
305end;
306
307function TApplication.GetTitle: string;
308begin
309 Result := GetNativeApplication.Title;
310end;
311
312function TApplication.GetShowMainForm: Boolean;
313begin
314 Result := GetNativeApplication.ShowMainForm;
315end;
316
317function TApplication.GetTaskBarBehavior: TTaskBarBehavior;
318begin
319 Result := GetNativeApplication.TaskBarBehavior;
320end;
321
322function TApplication.GetActive: Boolean;
323begin
324 Result := GetNativeApplication.Active;
325end;
326
327function TApplication.GetExeName: string;
328begin
329 Result := GetNativeApplication.ExeName;
330end;
331
332function TApplication.GetMainForm: TForm;
333begin
334 Result := FMainForm;
335end;
336
337procedure TApplication.SetShowMainForm(AValue: Boolean);
338begin
339 GetNativeApplication.ShowMainForm := AValue;
340end;
341
342procedure TApplication.SetTaskBarBehavior(AValue: TTaskBarBehavior);
343begin
344 GetNativeApplication.TaskBarBehavior := AValue;
345end;
346
347procedure TApplication.SetTitle(AValue: string);
348begin
349 GetNativeApplication.Title := AValue;
350end;
351
352function TApplication.GetNativeApplication: Forms.TApplication;
353begin
354 Result := Forms.Application;
355end;
356
357procedure DpiBeforeFinalization;
358// This is our ExitProc handler.
359begin
360 Application.DoBeforeFinalization;
361end;
362
363procedure TApplication.DoBeforeFinalization;
364var
365 I: Integer;
366begin
367 if Self = nil then Exit;
368 for I := ComponentCount - 1 downto 0 do begin
369 if I < ComponentCount then
370 Components[I].Free;
371 end;
372end;
373
374function DpiFindApplicationComponent(const ComponentName: string): TComponent;
375// Note: this function is used by TReader to auto rename forms to unique names.
376begin
377 Result := Application.FindComponent(ComponentName);
378end;
379
380constructor TApplication.Create(AOwner: TComponent);
381begin
382 RegisterFindGlobalComponentProc(@DpiFindApplicationComponent);
383 AddExitProc(@DpiBeforeFinalization);
384 inherited;
385end;
386
387destructor TApplication.Destroy;
388begin
389 UnregisterFindGlobalComponentProc(@DpiFindApplicationComponent);
390 inherited;
391end;
392
393procedure TApplication.Run;
394begin
395 if (FMainForm <> nil) and GetShowMainForm then FMainForm.Show;
396 GetNativeApplication.Run;
397end;
398
399procedure TApplication.Initialize;
400begin
401 GetNativeApplication.Initialize;
402end;
403
404procedure TApplication.Terminate;
405begin
406 GetNativeApplication.Terminate;
407end;
408
409procedure TApplication.ProcessMessages;
410begin
411 GetNativeApplication.ProcessMessages;
412end;
413
414procedure TApplication.UpdateMainForm(AForm: TForm);
415begin
416 if (FMainForm = nil)
417 and (FCreatingForm = AForm)
418 //and (not (AppDestroying in FFlags))
419 and not (AForm.FormStyle in [fsMDIChild, fsSplash])
420 then
421 FMainForm := AForm;
422 GetNativeApplication.UpdateMainForm(AForm.GetNativeForm);
423end;
424
425procedure TApplication.CreateForm(InstanceClass: TComponentClass; out
426 Reference);
427var
428 Instance: TComponent;
429 Ok: Boolean;
430 AForm: TForm;
431begin
432 // Allocate the instance, without calling the constructor
433 Instance := TComponent(InstanceClass.NewInstance);
434 // set the Reference before the constructor is called, so that
435 // events and constructors can refer to it
436 TComponent(Reference) := Instance;
437
438 Ok := False;
439 try
440 if (FCreatingForm = nil) and (Instance is TForm) then
441 FCreatingForm := TForm(Instance);
442 Instance.Create(Self);
443 Ok := True;
444 finally
445 if not Ok then begin
446 TComponent(Reference) := nil;
447 if FCreatingForm = Instance then
448 FCreatingForm := nil;
449 end;
450 end;
451
452 if (Instance is TForm) then begin
453 AForm := TForm(Instance);
454 UpdateMainForm(AForm);
455 if FMainForm = AForm then AForm.GetNativeForm.HandleNeeded;
456 if AForm.FormStyle = fsSplash then begin
457 // show the splash form and handle the paint message
458 AForm.Show;
459 AForm.Invalidate;
460 ProcessMessages;
461 end;
462 end;
463end;
464
465procedure TApplication.RemoveStayOnTop(const ASystemTopAlso: Boolean);
466begin
467 GetNativeApplication.RemoveStayOnTop(ASystemTopAlso);
468end;
469
470procedure TApplication.RestoreStayOnTop(const ASystemTopAlso: Boolean);
471begin
472 GetNativeApplication.RestoreStayOnTop(ASystemTopAlso);
473end;
474
475function TApplication.MessageBox(Text, Caption: PChar; Flags: Longint
476 ): Integer;
477begin
478 Result := Application.MessageBox(Text, Caption, Flags);
479end;
480
481{ TForm }
482
483function TForm.GetBorderIcons: TBorderIcons;
484begin
485 Result := GetNativeForm.BorderIcons;
486end;
487
488function TForm.GetBorderStyle: TFormBorderStyle;
489begin
490 Result := GetNativeForm.BorderStyle;
491end;
492
493function TForm.GetDesignTimePPI: Integer;
494begin
495 Result := GetNativeForm.DesignTimePPI;
496end;
497
498function TForm.GetFormState: TFormState;
499begin
500 Result := GetNativeForm.FormState;
501end;
502
503function TForm.GetFormStyle: TFormStyle;
504begin
505 Result := GetNativeForm.FormStyle;
506end;
507
508function TForm.GetKeyPreview: Boolean;
509begin
510 Result := GetNativeForm.KeyPreview;
511end;
512
513function TForm.GetLCLVersion: string;
514begin
515 Result := GetNativeForm.LCLVersion;
516end;
517
518function TForm.GetModalResult: TModalResult;
519begin
520 Result := GetNativeForm.ModalResult;
521end;
522
523function TForm.GetOnCloseQuery: TCloseQueryEvent;
524begin
525 Result := GetNativeForm.OnCloseQuery;
526end;
527
528function TForm.GetOnCreate: TNotifyEvent;
529begin
530 Result := GetNativeForm.OnCreate;
531end;
532
533function TForm.GetOnDeactivate: TNotifyEvent;
534begin
535 Result := GetNativeForm.OnDeactivate;
536end;
537
538function TForm.GetOnDestroy: TNotifyEvent;
539begin
540 Result := GetNativeForm.OnDestroy;
541end;
542
543function TForm.GetOnHide: TNotifyEvent;
544begin
545 Result := GetNativeForm.OnHide;
546end;
547
548function TForm.GetOnShow: TNotifyEvent;
549begin
550 Result := GetNativeForm.OnShow;
551end;
552
553function TForm.GetPosition: TPosition;
554begin
555 Result := GetNativeForm.Position;
556end;
557
558function TForm.GetRestoredHeight: Integer;
559begin
560 Result := ScaleFromNative(GetNativeForm.RestoredHeight);
561end;
562
563function TForm.GetRestoredLeft: Integer;
564begin
565 Result := ScaleFromNative(GetNativeForm.RestoredLeft);
566end;
567
568function TForm.GetRestoredTop: Integer;
569begin
570 Result := ScaleFromNative(GetNativeForm.RestoredTop);
571end;
572
573function TForm.GetRestoredWidth: Integer;
574begin
575 Result := ScaleFromNative(GetNativeForm.RestoredWidth);
576end;
577
578function TForm.GetShowInTaskbar: TShowInTaskbar;
579begin
580 Result := GetNativeForm.ShowInTaskBar;
581end;
582
583function TForm.GetWindowState: TWindowState;
584begin
585 Result := GetNativeForm.WindowState;
586end;
587
588procedure TForm.SetBorderIcons(AValue: TBorderIcons);
589begin
590 GetNativeForm.BorderIcons := AValue;
591end;
592
593procedure TForm.SetBorderStyle(AValue: TFormBorderStyle);
594begin
595 GetNativeForm.BorderStyle := AValue;
596end;
597
598procedure TForm.SetDesignTimePPI(AValue: Integer);
599begin
600 GetNativeForm.DesignTimePPI := AValue;
601end;
602
603procedure TForm.SetFormStyle(AValue: TFormStyle);
604begin
605 GetNativeForm.FormStyle := AValue;
606end;
607
608procedure TForm.SetKeyPreview(AValue: Boolean);
609begin
610 GetNativeForm.KeyPreview := AValue;
611end;
612
613procedure TForm.SetLCLVersion(AValue: string);
614begin
615 GetNativeForm.LCLVersion := AValue;
616end;
617
618procedure TForm.SetModalResult(AValue: TModalResult);
619begin
620 GetNativeForm.ModalResult := AValue;
621end;
622
623procedure TForm.SetOnCloseQuery(AValue: TCloseQueryEvent);
624begin
625 GetNativeForm.OnCloseQuery := AValue;
626end;
627
628procedure TForm.SetOnCreate(AValue: TNotifyEvent);
629begin
630 GetNativeForm.OnCreate := AValue;
631end;
632
633procedure TForm.SetOnDeactivate(AValue: TNotifyEvent);
634begin
635 GetNativeForm.OnDeactivate := AValue;
636end;
637
638procedure TForm.SetOnDestroy(AValue: TNotifyEvent);
639begin
640 GetNativeForm.OnDestroy := AValue;
641end;
642
643procedure TForm.SetOnHide(AValue: TNotifyEvent);
644begin
645 GetNativeForm.OnHide := AValue;
646end;
647
648procedure TForm.SetOnShow(AValue: TNotifyEvent);
649begin
650 GetNativeForm.OnShow := AValue;
651end;
652
653procedure TForm.DoOnCreate;
654begin
655 if Assigned(GetNativeForm.OnCreate) then
656 GetNativeForm.OnCreate(Self);
657end;
658
659procedure TForm.FormMessageHandler(var TheMessage: TLMessage);
660begin
661 Dispatch(TheMessage);
662end;
663
664procedure TForm.SetPosition(AValue: TPosition);
665begin
666 GetNativeForm.Position := AValue;
667end;
668
669procedure TForm.SetShowInTaskBar(AValue: TShowInTaskbar);
670begin
671 GetNativeForm.ShowInTaskBar := AValue;
672end;
673
674procedure TForm.SetWindowState(AValue: TWindowState);
675begin
676 GetNativeForm.WindowState := AValue;
677end;
678
679procedure TForm.ActivateHandler(Sender: TObject);
680begin
681 if Assigned(Screen.FActiveForm) then begin
682 if Screen.FPrevActiveForms.IndexOf(Screen.FActiveForm) <> - 1 then
683 Screen.FPrevActiveForms.Remove(Screen.FActiveForm);
684 Screen.FPrevActiveForms.Add(Screen.FActiveForm);
685 end;
686 Screen.FActiveForm := Self;
687 if Assigned(FOnActivate) then FOnActivate(Sender);
688end;
689
690procedure TForm.DeactivateHandler(Sender: TObject);
691begin
692 if Screen.FPrevActiveForms.Count > 0 then begin
693 Screen.FActiveForm := Screen.FPrevActiveForms.Last;
694 Screen.FPrevActiveForms.Delete(Screen.FPrevActiveForms.Count - 1);
695 end else Screen.FActiveForm := nil;
696 //Screen.UpdateActiveFormFromNativeScreen;
697 if Assigned(FOnDeactivate) then FOnDeactivate(Sender);
698end;
699
700procedure TForm.DoClose(var CloseAction: TCloseAction);
701begin
702 if Assigned(FOnClose) then FOnClose(Self, CloseAction);
703end;
704
705procedure TForm.CloseHandler(Sender: TObject; var CloseAction: TCloseAction);
706begin
707 Close;
708end;
709
710procedure TForm.CloseQueryHandler(Sender : TObject; var CanClose : boolean);
711begin
712 if Assigned(FOnCloseQuery) then FOnCloseQuery(Self, CanClose);
713end;
714
715procedure TForm.CreateParams(var p: TCreateParams);
716begin
717 // TODO: NativeForm.CreateParams(P);
718end;
719
720// This method is called by TWriter to retrieve the child components to write
721procedure TForm.GetChildren(Proc: TGetChildProc; Root: TComponent);
722var
723 I: Integer;
724 OwnedComponent: TComponent;
725begin
726 DebugLn(['TDpiForm.GetChildren ComponentCount=', ComponentCount]);
727 inherited GetChildren(Proc, Root);
728 if Root = Self then begin
729 for I := 0 to ComponentCount - 1 do begin
730 OwnedComponent := Components[I];
731 if not OwnedComponent.HasParent then Proc(OwnedComponent);
732 end;
733 end;
734end;
735
736function TForm.GetNativeScrollingWinControl: Forms.TScrollingWinControl;
737begin
738 Result := GetNativeForm;
739end;
740
741function TForm.GetNativeForm: Forms.TForm;
742begin
743 if not Assigned(NativeForm) then begin
744 NativeForm := TFormEx.CreateNew(nil);
745 (NativeForm as TFormEx).OnMessage := FormMessageHandler;
746 //NativeForm := Forms.TForm.Create(nil);
747 end;
748 Result := NativeForm;
749end;
750
751procedure TForm.UpdateNativeControl;
752begin
753 inherited;
754 GetNativeForm.OnActivate := ActivateHandler;
755 GetNativeForm.OnDeactivate := DeactivateHandler;
756 GetNativeForm.OnClose := CloseHandler;
757 GetNativeForm.OnCloseQuery := CloseQueryHandler;
758 GetNativeForm.Name := Name + 'Native';
759end;
760
761procedure TForm.AfterConstruction;
762begin
763 inherited;
764 DoOnCreate;
765end;
766
767function TForm.ShowModal: Integer;
768begin
769 Result := GetNativeForm.ShowModal;
770end;
771
772procedure TForm.SetFocus;
773begin
774 GetNativeForm.SetFocus;
775end;
776
777procedure TForm.Close;
778var
779 CloseAction: TCloseAction;
780 IsMainForm: Boolean;
781begin
782 if (fsModal in FormState) and (ModalResult = 0) then
783 ModalResult := mrCancel
784 else
785 begin
786 if CloseQuery then
787 begin
788 // IsMainForm flag set if we are closing MainForm or its parent
789 IsMainForm := (Application.MainForm = Self) or (Self.IsParentOf(Application.MainForm));
790 // Prepare default close action
791 if FormStyle = fsMDIChild then
792 begin
793 CloseAction := caNone;
794 // TODO: mdi logic
795 end
796 else
797 begin
798 if IsMainForm then
799 CloseAction := caFree
800 else
801 CloseAction := caHide;
802 end;
803 // call event handler and let user modify CloseAction
804 DoClose(CloseAction);
805 // execute action according to close action
806 case CloseAction of
807 caHide: Hide;
808 caMinimize: WindowState := wsMinimized;
809 caFree:
810 begin
811 // if form is MainForm, then terminate the application
812 // the owner of the MainForm is the application,
813 // so the Application will take care of free-ing the form
814 // and Release is not necessary
815 if IsMainForm then
816 Application.Terminate
817 else
818 Release;
819 end;
820 end;
821 end;
822 end;
823end;
824
825function TForm.CloseQuery: boolean;
826begin
827 Result := True;
828 if Assigned(FOnCloseQuery) then
829 FOnCloseQuery(Self, Result);
830end;
831
832procedure TForm.BringToFront;
833begin
834 GetNativeForm.BringToFront;
835end;
836
837procedure TForm.Release;
838begin
839 Free;
840end;
841
842// Init the component with an IDE resource
843constructor TForm.Create(TheOwner: TComponent);
844begin
845 //inherited;
846 //DebugLn(['TDpiForm.Create ', DbgSName(TheOwner)]);
847 GlobalNameSpace.BeginWrite;
848 try
849 CreateNew(TheOwner, 1); // this calls BeginFormUpdate, which is ended in AfterConstruction
850 if (ClassType <> TForm) and not (csDesigning in ComponentState) then begin
851 if not InitResourceComponent(Self, TDataModule) then begin
852 raise EResNotFound.Create('Resource missing for class ' + ClassName);
853 end;
854 end;
855 finally
856 GlobalNameSpace.EndWrite;
857 end;
858 ScreenChanged;
859 UpdateNativeControl;
860end;
861
862constructor TForm.CreateNew(AOwner: TComponent; Num: Integer);
863begin
864 inherited Create(AOwner);
865 Screen.AddForm(Self);
866end;
867
868destructor TForm.Destroy;
869begin
870 // TODO: Can't destroy directly?
871 TFormEx(NativeForm).OnMessage := nil;
872 FreeAndNil(NativeForm);
873
874 Screen.RemoveForm(Self);
875 inherited;
876end;
877
878{ TScreen }
879
880procedure TScreen.SetDpi(AValue: Integer);
881begin
882 if FDpi = AValue then Exit;
883 FDpi := AValue;
884 ScreenInfo.Dpi := Dpi;
885 UpdateForms;
886end;
887
888function TScreen.GetWidth: Integer;
889begin
890 Result := ScaleFromNative(LCLScreen.Width);
891end;
892
893procedure TScreen.SetCursor(AValue: TCursor);
894begin
895 LCLScreen.Cursor := AValue;
896end;
897
898procedure TScreen.SetCursors(Index: Integer; AValue: HCURSOR);
899begin
900 LCLScreen.Cursors[Index] := AValue;
901end;
902
903function TScreen.GetHeight: Integer;
904begin
905 Result := ScaleFromNative(LCLScreen.Height);
906end;
907
908function TScreen.GetFormCount: Integer;
909begin
910 Result := FForms.Count;
911end;
912
913function TScreen.GetForms(Index: Integer): TForm;
914begin
915 Result := FForms[Index];
916end;
917
918procedure TScreen.AddForm(AForm: TForm);
919begin
920 if AForm is TForm then begin
921 FForms.Add(AForm);
922 //Application.UpdateVisible;
923 end;
924end;
925
926function TScreen.GetDesktopHeight: Integer;
927begin
928 Result := ScaleFromNative(LCLScreen.DesktopHeight);
929end;
930
931function TScreen.GetDesktopLeft: Integer;
932begin
933 Result := ScaleFromNative(LCLScreen.DesktopLeft);
934end;
935
936function TScreen.GetDesktopTop: Integer;
937begin
938 Result := ScaleFromNative(LCLScreen.DesktopTop);
939end;
940
941function TScreen.GetDesktopWidth: Integer;
942begin
943 Result := ScaleFromNative(LCLScreen.DesktopWidth);
944end;
945
946procedure TScreen.RemoveForm(AForm: TForm);
947begin
948 FForms.Remove(AForm);
949 FPrevActiveForms.Remove(AForm);
950 if AForm = FActiveForm then begin
951 FActiveForm := nil;
952 end;
953end;
954
955function TScreen.GetActiveForm: TForm;
956begin
957 Result := FActiveForm;
958end;
959
960function TScreen.GetCursor: TCursor;
961begin
962 Result := LCLScreen.Cursor;
963end;
964
965function TScreen.GetCursors(Index: Integer): HCURSOR;
966begin
967 Result := LCLScreen.Cursors[Index];
968end;
969
970procedure TScreen.UpdateForms;
971var
972 I: Integer;
973begin
974 for I := 0 to FForms.Count - 1 do
975 FForms[I].ScreenChanged;
976end;
977
978function TScreen.DisableForms(SkipForm: TForm; DisabledList: Classes.TList
979 ): Classes.TList;
980begin
981 Result := LCLScreen.DisableForms(SkipForm.GetNativeForm, DisabledList);
982end;
983
984procedure TScreen.EnableForms(var AFormList: Classes.TList);
985begin
986 LCLScreen.EnableForms(AFormList);
987end;
988
989function TScreen.GetSystemDpi: Integer;
990begin
991 Result := LCLScreen.PixelsPerInch;
992end;
993
994constructor TScreen.Create;
995begin
996 FForms := TForms.Create;
997 FForms.OwnsObjects := False;
998 FPrevActiveForms := TForms.Create;
999 FPrevActiveForms.OwnsObjects := False;
1000 // Froms.Screen.PixelsPerInch is not initialized at this point
1001 Dpi := 96;
1002end;
1003
1004destructor TScreen.Destroy;
1005begin
1006 FreeAndNil(FForms);
1007 FreeAndNil(FPrevActiveForms);
1008 inherited;
1009end;
1010
1011procedure TScreen.UpdateActiveFormFromNativeScreen;
1012var
1013 I: Integer;
1014 F: TForm;
1015begin
1016 if LCLScreen.ActiveForm = nil then FActiveForm := nil
1017 else begin
1018 for I := 0 to FormCount - 1 do begin
1019 F := Forms[I];
1020 if F.GetNativeForm = LCLScreen.ActiveForm then begin
1021 FActiveForm := F;
1022 Break;
1023 end;
1024 end;
1025 end;
1026end;
1027
1028{ TControlScrollBar }
1029
1030function TControlScrollBar.GetVisible: Boolean;
1031begin
1032
1033end;
1034
1035procedure TControlScrollBar.SetVisible(AValue: Boolean);
1036begin
1037
1038end;
1039
1040initialization
1041
1042RegisterPropertyToSkip(TForm, 'OldCreateOrder', 'Native compatibility property', '');
1043RegisterPropertyToSkip(TForm, 'TextHeight', 'Native compatibility property', '');
1044RegisterPropertyToSkip(TForm, 'Scaled', 'Native compatibility property', '');
1045RegisterPropertyToSkip(TForm, 'TransparentColorValue', 'Native compatibility property', '');
1046Screen := TScreen.Create;
1047Application := TApplication.Create(nil);
1048
1049finalization
1050
1051FreeAndNil(Application);
1052FreeAndNil(Screen);
1053
1054end.
1055
Note: See TracBrowser for help on using the repository browser.