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