1 unit sparta_BasicFakeCustom;
2
3 {$mode delphi}{$H+}
4
5 interface
6
7 uses
8 Classes, SysUtils,
9 LCLType, LCLIntf, Controls, Forms,
10 sparta_InterfacesMDI, sparta_FormBackgroundForMDI;
11
12 type
13
14 { TFormImpl }
15
16 TFormImpl = class(TComponent, IDesignedRealFormHelper, IDesignedForm)
17 private
18 FDesignedRealForm: IDesignedRealForm;
19 FHackLeft: Integer;
20 FHackTop: Integer;
21 FHackWidth: Integer;
22 FHackHeight: Integer;
23 FOnChangeHackedBounds: TNotifyEvent;
24 protected
25 FForm: TCustomForm;
26 FUpdate: boolean;
27 procedure SetOnChangeHackedBounds(const AValue: TNotifyEvent);
GetOnChangeHackedBoundsnull28 function GetOnChangeHackedBounds: TNotifyEvent;
PositionDeltanull29 function PositionDelta: TPoint;
30
GetRealBoundsnull31 function GetRealBounds(AIndex: Integer): Integer; virtual;
32 procedure SetRealBounds(AIndex: Integer; AValue: Integer); virtual;
GetPublishedBoundsnull33 function GetPublishedBounds(AIndex: Integer): Integer; virtual;
34 procedure SetPublishedBounds(AIndex: Integer; AValue: Integer); virtual;
35
36 procedure SetHorzScrollPosition(AValue: Integer); virtual;
37 procedure SetVertScrollPosition(AValue: Integer); virtual;
38
39 // own custom form scrool system
GetHorzScrollPositionnull40 function GetHorzScrollPosition: Integer; virtual;
GetVertScrollPositionnull41 function GetVertScrollPosition: Integer; virtual;
42
43 procedure SetRealBorderStyle(AVal: TFormBorderStyle); virtual;
44 procedure SetRealBorderIcons(AVal: TBorderIcons); virtual;
45 procedure SetRealFormStyle(AVal: TFormStyle); virtual;
46 procedure SetRealPopupMode(AVal: TPopupMode); virtual;
47 procedure SetRealPopupParent(AVal: TCustomForm); virtual;
48
GetRealBorderStylenull49 function GetRealBorderStyle: TFormBorderStyle; virtual;
GetRealBorderIconsnull50 function GetRealBorderIcons: TBorderIcons; virtual;
GetRealFormStylenull51 function GetRealFormStyle: TFormStyle; virtual;
GetRealPopupModenull52 function GetRealPopupMode: TPopupMode; virtual;
GetRealPopupParentnull53 function GetRealPopupParent: TCustomForm; virtual;
54
GetFormnull55 function GetForm: TCustomForm; virtual;
GetUpdatenull56 function GetUpdate: Boolean; virtual;
57
58 procedure DoChangeHackedBounds; virtual;
59
GetLogicalClientRectnull60 function GetLogicalClientRect(ALogicalClientRect: TRect): TRect; virtual;
61 public
62 property RealLeft: Integer index 0 read GetRealBounds write SetRealBounds;
63 property RealTop: Integer index 1 read GetRealBounds write SetRealBounds;
64 property RealWidth: Integer index 2 read GetRealBounds write SetRealBounds;
65 property RealHeight: Integer index 3 read GetRealBounds write SetRealBounds;
66 property RealBorderStyle: TFormBorderStyle read GetRealBorderStyle write SetRealBorderStyle;
67 property RealBorderIcons: TBorderIcons read GetRealBorderIcons write SetRealBorderIcons;
68 property RealFormStyle: TFormStyle read GetRealFormStyle write SetRealFormStyle;
69
70 constructor Create(AOwner: TComponent; AForm: TCustomForm); virtual; reintroduce;
71 destructor Destroy; override;
72
73 procedure BeginUpdate; virtual;
74 procedure EndUpdate({%H-}AModified: Boolean = False); virtual;
75
76 procedure ShowWindow; virtual;
77 procedure HideWindow; virtual;
78
79 property Update: Boolean read GetUpdate;
80 public
81 property Left: Integer index 0 read GetPublishedBounds write SetPublishedBounds;
82 property Top: Integer index 1 read GetPublishedBounds write SetPublishedBounds;
83 property Width: Integer index 2 read GetPublishedBounds write SetPublishedBounds;
84 property Height: Integer index 3 read GetPublishedBounds write SetPublishedBounds;
85 public
QueryInterfacenull86 function QueryInterface(constref IID: TGUID; out Obj): HResult; override;
87 end;
88
89 { TFormContainer }
90
91 TFormContainer = class(TCustomForm, IDesignedRealForm, IDesignedForm, IDesignedFormBackground)
92 private
93 FDesignedForm: TFormImpl;
GetDesignedFormnull94 function GetDesignedForm: TFormImpl;
95 protected
96 property DesignedForm: TFormImpl read GetDesignedForm implements IDesignedForm;
GetLogicalClientRectnull97 function GetLogicalClientRect: TRect; override;
98 protected
GetRealBoundsnull99 function GetRealBounds(AIndex: Integer): Integer; virtual;
100 procedure SetRealBounds(AIndex: Integer; AValue: Integer); virtual;
GetPublishedBoundsnull101 function GetPublishedBounds(AIndex: Integer): Integer; virtual;
102 procedure SetPublishedBounds(AIndex: Integer; AValue: Integer); virtual;
103
104 procedure SetRealBorderStyle(AVal: TFormBorderStyle); virtual;
105 procedure SetRealBorderIcons(AVal: TBorderIcons); virtual;
106 procedure SetRealFormStyle(AVal: TFormStyle); virtual;
107 procedure SetRealPopupMode(AVal: TPopupMode); virtual;
108 procedure SetRealPopupParent(AVal: TCustomForm); virtual;
109
GetRealBorderStylenull110 function GetRealBorderStyle: TFormBorderStyle; virtual;
GetRealBorderIconsnull111 function GetRealBorderIcons: TBorderIcons; virtual;
GetRealFormStylenull112 function GetRealFormStyle: TFormStyle; virtual;
GetRealPopupModenull113 function GetRealPopupMode: TPopupMode; virtual;
GetRealPopupParentnull114 function GetRealPopupParent: TCustomForm; virtual;
115 protected
116 FHandledForm: TCustomForm;
117 FBackground: IDesignedFormBackground;
118
119 procedure SetHandledForm(AForm: TCustomForm);
120 public
121 constructor CreateNew(AOwner: TComponent; Num: Integer = 0); override;
122 destructor Destroy; override;
123
124 property HandledForm: TCustomForm read FHandledForm write SetHandledForm;
125 property Background: IDesignedFormBackground read FBackground implements IDesignedFormBackground;
126 published
127 property Left: Integer index 0 read GetPublishedBounds write SetPublishedBounds;
128 property Top: Integer index 1 read GetPublishedBounds write SetPublishedBounds;
129 property Width: Integer index 2 read GetPublishedBounds write SetPublishedBounds;
130 property Height: Integer index 3 read GetPublishedBounds write SetPublishedBounds;
131 property ClientWidth: Integer index 2 read GetPublishedBounds write SetPublishedBounds;
132 property ClientHeight: Integer index 3 read GetPublishedBounds write SetPublishedBounds;
133 end;
134
135 implementation
136
137 type
138 TFormAccess = class(TForm);
139
140 { TDesignedFormImpl }
141
GetPublishedBoundsnull142 function TFormImpl.GetPublishedBounds(AIndex: Integer): Integer;
143 begin
144 case AIndex of
145 0: Result := FForm.Left;
146 1: Result := FForm.Top;
147 2: Result := FForm.Width;
148 3: Result := FForm.Height;
149 end;
150 //case AIndex of
151 // 0: Result := FHackLeft;
152 // 1: Result := FHackTop;
153 // 2: Result := FHackWidth;
154 // 3: Result := FHackHeight;
155 //end;
156 end;
157
158 procedure TFormImpl.SetPublishedBounds(AIndex: Integer; AValue: Integer);
159 const
160 cMinWidth = 135;
161 cMaxWidth = 5*1024; // huge Mac monitors have 5K pixels width
162 begin
163 if AIndex = 2 then
164 if AValue < cMinWidth then
165 AValue := cMinWidth;
166
167 if AIndex in [2, 3] then
168 if AValue > cMaxWidth then
169 AValue := cMaxWidth;
170
171 case AIndex of
172 0: FHackLeft := AValue;
173 1: FHackTop := AValue;
174 2: FHackWidth := AValue;
175 3: FHackHeight := AValue;
176 end;
177
178 DoChangeHackedBounds;
179 end;
180
181 {-----------------------------------------------
182 Real values inherited for design form
183 {----------------------------------------------}
184
GetRealBoundsnull185 function TFormImpl.GetRealBounds(AIndex: Integer): Integer;
186 begin
187 case AIndex of
188 0: Result := FForm.Left;
189 1: Result := FForm.Top;
190 2: Result := FForm.Width;
191 3: Result := FForm.Height;
192 end;
193
194 //FForm.;
195 //Result := 0;// FDesignedRealForm.GetRealBounds(AIndex);
196 end;
197
198 procedure TFormImpl.SetRealBounds(AIndex: Integer; AValue: Integer);
199
200 procedure AdjustSize;
201 var
202 LFormRect: TRect;
203 LRealValue, LValue: Integer;
204 begin
205 LFormRect := Rect(0, 0, 0, 0);;
206 LCLIntf.GetClientRect(GetForm.Handle, LFormRect);
207 LRealValue := GetRealBounds(AIndex);
208 {$IF FPC_FULLVERSION < 30101}
209 case AIndex of
210 0: LValue := LFormRect.Left;
211 1: LValue := LFormRect.Top;
212 2: LValue := LFormRect.Right;
213 3: LValue := LFormRect.Bottom;
214 end;
215 {$ELSE}
216 LValue := LFormRect.Vector[AIndex];
217 {$ENDIF}
218
219 if LValue <> LRealValue then
220 FDesignedRealForm.SetRealBounds(AIndex, AValue - (LRealValue - LValue));
221 end;
222
223 begin
224 {FDesignedRealForm.SetRealBounds(AIndex, AValue);
225
226 if AIndex = 2 then
227 AdjustSize;}
228 end;
229
230 procedure TFormImpl.SetRealBorderStyle(AVal: TFormBorderStyle);
231 begin
232 //FDesignedRealForm.SetRealBorderStyle(AVal);
233 end;
234
235 procedure TFormImpl.SetRealBorderIcons(AVal: TBorderIcons);
236 begin
237 //FDesignedRealForm.SetRealBorderIcons(AVal);
238 end;
239
240 procedure TFormImpl.SetRealFormStyle(AVal: TFormStyle);
241 begin
242 //FDesignedRealForm.SetRealFormStyle(AVal);
243 end;
244
245 procedure TFormImpl.SetRealPopupMode(AVal: TPopupMode);
246 begin
247 //FDesignedRealForm.SetRealPopupMode(AVal);
248 end;
249
250 procedure TFormImpl.SetRealPopupParent(AVal: TCustomForm);
251 begin
252 //FDesignedRealForm.SetRealPopupParent(AVal);
253 end;
254
GetRealBorderStylenull255 function TFormImpl.GetRealBorderStyle: TFormBorderStyle;
256 begin
257 Result := bsNone;//FDesignedRealForm.GetRealBorderStyle;
258 end;
259
GetRealBorderIconsnull260 function TFormImpl.GetRealBorderIcons: TBorderIcons;
261 begin
262 Result := [];//FDesignedRealForm.GetRealBorderIcons;
263 end;
264
GetRealFormStylenull265 function TFormImpl.GetRealFormStyle: TFormStyle;
266 begin
267 Result := fsNormal;//FDesignedRealForm.GetRealFormStyle;
268 end;
269
GetRealPopupModenull270 function TFormImpl.GetRealPopupMode: TPopupMode;
271 begin
272 Result := pmNone//FDesignedRealForm.GetRealPopupMode;
273 end;
274
GetRealPopupParentnull275 function TFormImpl.GetRealPopupParent: TCustomForm;
276 begin
277 Result := nil//FDesignedRealForm.GetRealPopupParent;
278 end;
279
280 //////
281
GetFormnull282 function TFormImpl.GetForm: TCustomForm;
283 begin
284 Result := FForm;
285 end;
286
TFormImpl.GetUpdatenull287 function TFormImpl.GetUpdate: Boolean;
288 begin
289 Result := FUpdate;
290 end;
291
GetOnChangeHackedBoundsnull292 function TFormImpl.GetOnChangeHackedBounds: TNotifyEvent;
293 begin
294 Result := FOnChangeHackedBounds;
295 end;
296
TFormImpl.PositionDeltanull297 function TFormImpl.PositionDelta: TPoint;
298
299 procedure FormBorderDelta;
300 begin
301 Result.X := GetSystemMetrics(SM_CXSIZEFRAME);
302 Result.Y := GetSystemMetrics(SM_CYSIZEFRAME) + GetSystemMetrics(SM_CYCAPTION);
303 end;
304
305 begin
306 Result := Point(0, 0);
307 {$IFDEF WINDOWS}
308 FormBorderDelta;
309 {$ENDIF}
310 end;
311
312 procedure TFormImpl.SetOnChangeHackedBounds(const AValue: TNotifyEvent);
313 begin
314 FOnChangeHackedBounds := AValue;
315 end;
316
317 /////// positions
318
319 procedure TFormImpl.SetHorzScrollPosition(AValue: Integer);
320 begin
321 RealLeft := -PositionDelta.x - AValue;
322 // ! must. resize problem for controls with Align = Top, Right etc.
323 RealWidth := Width;
324 RealHeight := Height;
325 end;
326
327 procedure TFormImpl.SetVertScrollPosition(AValue: Integer);
328 begin
329 RealTop := -PositionDelta.y - AValue;
330 // ! must. resize problem for controls with Align = Top, Right etc.
331 RealWidth := Width;
332 RealHeight := Height;
333 end;
334
TFormImpl.GetHorzScrollPositionnull335 function TFormImpl.GetHorzScrollPosition: Integer;
336 begin
337 Result := -(RealLeft {+ PositionDelta.x});
338 end;
339
TFormImpl.GetVertScrollPositionnull340 function TFormImpl.GetVertScrollPosition: Integer;
341 begin
342 Result := -(RealTop {+ PositionDelta.y});
343 end;
344
345 procedure TFormImpl.BeginUpdate;
346 begin
347 FUpdate := True;
348 end;
349
350 procedure TFormImpl.EndUpdate(AModified: Boolean);
351 begin
352 FUpdate := False;
353 end;
354
355 procedure TFormImpl.ShowWindow;
356 begin
357 if FForm.Parent = nil then
358 LCLIntf.ShowWindow(FForm.Handle, SW_SHOW);
359 end;
360
361 procedure TFormImpl.HideWindow;
362 begin
363 if FForm.Parent = nil then
364 LCLIntf.ShowWindow(FForm.Handle, SW_HIDE);
365 end;
366
QueryInterfacenull367 function TFormImpl.QueryInterface(constref IID: TGUID; out Obj
368 ): HResult;
369 begin
370 Result := inherited QueryInterface(IID, Obj);
371 if Result <> S_OK then
372 Result := TFormAccess(FForm).QueryInterface(IID, Obj);
373 end;
374
375 procedure TFormImpl.DoChangeHackedBounds;
376 begin
377 if not FUpdate and Assigned(FOnChangeHackedBounds) then
378 FOnChangeHackedBounds(FForm);
379 end;
380
TFormImpl.GetLogicalClientRectnull381 function TFormImpl.GetLogicalClientRect(ALogicalClientRect: TRect): TRect;
382 begin
383 Result:=ALogicalClientRect;
384 end;
385
386 constructor TFormImpl.Create(AOwner: TComponent; AForm: TCustomForm);
387 begin
388 inherited Create(AOwner);
389 FForm := AForm;
390 FDesignedRealForm := Self as IDesignedRealForm;
391 end;
392
393 destructor TFormImpl.Destroy;
394 begin
395 Pointer(FDesignedRealForm) := nil;
396 inherited Destroy;
397 end;
398
399 { TFakeCustomForm }
400
GetDesignedFormnull401 function TFormContainer.GetDesignedForm: TFormImpl;
402 begin
403 if not Assigned(FDesignedForm) then
404 FDesignedForm := TFormImpl.Create(Self, Self);
405
406 Result := FDesignedForm;
407 end;
408
TFormContainer.GetLogicalClientRectnull409 function TFormContainer.GetLogicalClientRect: TRect;
410 begin
411 Result := DesignedForm.GetLogicalClientRect(inherited GetLogicalClientRect);
412 end;
413
GetRealBoundsnull414 function TFormContainer.GetRealBounds(AIndex: Integer): Integer;
415 begin
416 case AIndex of
417 0: Result := inherited Left;
418 1: Result := inherited Top;
419 2: Result := inherited Width;
420 3: Result := inherited Height;
421 end;
422 end;
423
424 procedure TFormContainer.SetRealBounds(AIndex: Integer; AValue: Integer);
425 begin
426 case AIndex of
427 0: inherited Left := AValue;
428 1: inherited Top := AValue;
429 2:
430 begin
431 inherited Width := AValue;
432 if FHandledForm <> nil then
433 FHandledForm.Width := AValue;
434 end;
435 3:
436 begin
437 inherited Height := AValue;
438 if FHandledForm <> nil then
439 FHandledForm.Height := AValue;
440 end;
441 end;
442 end;
443
GetPublishedBoundsnull444 function TFormContainer.GetPublishedBounds(AIndex: Integer): Integer;
445 begin
446 Result := DesignedForm.GetPublishedBounds(AIndex);
447 end;
448
449 procedure TFormContainer.SetPublishedBounds(AIndex: Integer; AValue: Integer);
450 begin
451 case AIndex of
452 0, 1: DesignedForm.SetPublishedBounds(AIndex, AValue);
453 2, 3:
454 begin
455 DesignedForm.SetPublishedBounds(AIndex, AValue);
456 SetRealBounds(AIndex, DesignedForm.GetPublishedBounds(AIndex));
457 end;
458 end;
459 end;
460
461 constructor TFormContainer.CreateNew(AOwner: TComponent; Num: Integer);
462 begin
463 FBackground := TfrFormBackgroundForMDI.Create(DesignedForm);
464 FBackground._AddRef;
465
466 inherited CreateNew(AOwner, Num);
467
468 Left := inherited Left;
469 Top := inherited Top;
470 Width := inherited Width;
471 Height := inherited Height;
472 end;
473
474 destructor TFormContainer.Destroy;
475 var
476 I: IInterfaceComponentReference;
477 begin
478 // we need to call "Screen.RemoveForm" to perform
479 // references back to nil by IDesignedForm to FDesignedForm
480 inherited Destroy;
481
482 FBackground.QueryInterface(IInterfaceComponentReference, I); // only way to omit SIGSEGV
483 I.GetComponent.Free;
484 Pointer(I) := nil; // omit _Release (Free is above)
485 Pointer(FBackground) := nil; // omit _Release (Free is above)
486
487 if Assigned(FDesignedForm) then
488 FreeAndNil(FDesignedForm);
489 end;
490
491 procedure TFormContainer.SetRealBorderStyle(AVal: TFormBorderStyle);
492 begin
493 inherited BorderStyle := AVal;
494 end;
495
496 procedure TFormContainer.SetRealBorderIcons(AVal: TBorderIcons);
497 begin
498 inherited BorderIcons := AVal;
499 end;
500
501 procedure TFormContainer.SetRealFormStyle(AVal: TFormStyle);
502 begin
503 inherited FormStyle := AVal;
504 end;
505
506 procedure TFormContainer.SetRealPopupMode(AVal: TPopupMode);
507 begin
508 inherited PopupMode := AVal;
509 end;
510
511 procedure TFormContainer.SetRealPopupParent(AVal: TCustomForm);
512 begin
513 inherited PopupParent := AVal;
514 end;
515
TFormContainer.GetRealBorderStylenull516 function TFormContainer.GetRealBorderStyle: TFormBorderStyle;
517 begin
518 Result := inherited BorderStyle;
519 end;
520
GetRealBorderIconsnull521 function TFormContainer.GetRealBorderIcons: TBorderIcons;
522 begin
523 Result := inherited BorderIcons;
524 end;
525
GetRealFormStylenull526 function TFormContainer.GetRealFormStyle: TFormStyle;
527 begin
528 Result := inherited FormStyle;
529 end;
530
GetRealPopupModenull531 function TFormContainer.GetRealPopupMode: TPopupMode;
532 begin
533 Result := inherited PopupMode;
534 end;
535
TFormContainer.GetRealPopupParentnull536 function TFormContainer.GetRealPopupParent: TCustomForm;
537 begin
538 Result := inherited PopupParent;
539 end;
540
541 procedure TFormContainer.SetHandledForm(AForm: TCustomForm);
542 begin
543 if FHandledForm = AForm then
544 Exit;
545
546 if FHandledForm <> nil then
547 FHandledForm.Parent := nil;
548
549 FHandledForm := AForm;
550
551 if FHandledForm <> nil then
552 FHandledForm.Parent := Self;
553 end;
554
555
556 end.
557
558