1 {
2 *****************************************************************************
3 See the file COPYING.modifiedLGPL.txt, included in this distribution,
4 for details about the license.
5 *****************************************************************************
6
7 Author: Maciej Izak
8
9 DaThoX 2004-2015
10 FreeSparta.com
11 }
12
13 unit sparta_FakeFormBackground;
14
15 {$mode objfpc}{$H+}
16
17 interface
18
19 uses
20 Classes, SysUtils, FileUtil,
21 // BGRAButton,
22 // BGRAImageButton,
23 Forms, Controls, StdCtrls, ExtCtrls, Menus, sparta_DesignedForm,
24 LCLType, LMessages, PropEdits, Graphics, sparta_InterfacesMDI;
25
26 type
27
28 { TfrFakeFormBackground }
29
30 TfrFakeFormBackground = class(TFrame, IDesignedFormBackground)
31 bBackground: TButton;
32 bTop: TButton;
33 bFormCaption: TButton;
34 bOther: TImage;
35 bResize: TImage;
36 bIcon: TImage;
37 bSystem: TImage;
38 bMaximalize: TImage;
39 bMinimalize: TImage;
40 bHelp: TImage;
41 eFormCaption: TEdit;
42 lRight: TLabel;
43 miNone: TMenuItem;
44 miSingle: TMenuItem;
45 miSizeable: TMenuItem;
46 miDialog: TMenuItem;
47 miToolWindow: TMenuItem;
48 miSizeToolWin: TMenuItem;
49 miAddMinimize: TMenuItem;
50 miAddSystemMenu: TMenuItem;
51 miAddMaximize: TMenuItem;
52 miAddHelp: TMenuItem;
53 miLine: TMenuItem;
54 miRemove: TMenuItem;
55 pmFormStyle: TPopupMenu;
56 pmBorderIcons: TPopupMenu;
57 procedure bFormCaptionClick(Sender: TObject);
58 procedure bIconClick(Sender: TObject);
59 procedure bOtherClick(Sender: TObject);
60 procedure bResizeClick(Sender: TObject);
61 procedure eFormCaptionExit(Sender: TObject);
62 procedure eFormCaptionKeyDown(Sender: TObject; var Key: Word;
63 Shift: TShiftState);
64 procedure miAddHelpClick(Sender: TObject);
65 procedure miNoneClick(Sender: TObject);
66 procedure miRemoveClick(Sender: TObject);
67 procedure pmBorderIconsPopup(Sender: TObject);
68 private
69 FDesignedForm: IDesignedForm;
70 FDesignedFakeForm: IDesignedFakeForm;
71
RootIsSelectednull72 function RootIsSelected: Boolean;
73
GetMarginnull74 function GetMargin(const AIndex: Integer): Integer;
75 procedure OnUserInputHandler(Sender: TObject; Msg: Cardinal);
76 procedure OnDesignRefreshPropertyValues;
77 protected
GetParentnull78 function GetParent: TWinControl; virtual;
79 procedure SetParent(AParent: TWinControl); override;
80
GetDesignedFormnull81 function GetDesignedForm: IDesignedForm;
GetResizeFramenull82 function GetResizeFrame: IResizeFrame;
83 procedure SetResizeFrame(AValue: IResizeFrame);
84 public
85 { public declarations }
86 constructor Create(const ADesignedForm: IDesignedForm; const ADesignedFakeForm: IDesignedFakeForm); virtual; reintroduce;
87 destructor Destroy; override;
88
89 procedure RefreshValues;
90
91 procedure UpdateBorderIcons;
92 procedure UpdateCaption;
93 end;
94
95 implementation
96
97 {$R *.lfm}
98 {$R *.res}
99
100 uses
101 sparta_MainIDE;
102
103 var
104 Frames: TList;
105
106 { TfrFakeFormBackground }
107
108 procedure TfrFakeFormBackground.miAddHelpClick(Sender: TObject);
109 begin
110 if Sender = miAddHelp then
111 FDesignedFakeForm.BorderIcons:=FDesignedFakeForm.BorderIcons + [biHelp]
112 else if Sender = miAddMaximize then
113 FDesignedFakeForm.BorderIcons:=FDesignedFakeForm.BorderIcons + [biMaximize]
114 else if Sender = miAddMinimize then
115 FDesignedFakeForm.BorderIcons:=FDesignedFakeForm.BorderIcons + [biMinimize]
116 else if Sender = miAddSystemMenu then
117 FDesignedFakeForm.BorderIcons:=FDesignedFakeForm.BorderIcons + [biSystemMenu];
118
119 GlobalDesignHook.Modified(Self);
120 if not RootIsSelected then
121 RefreshValues
122 else
123 GlobalDesignHook.RefreshPropertyValues;
124 end;
125
126 procedure TfrFakeFormBackground.miNoneClick(Sender: TObject);
127 begin
128 if Sender = miNone then
129 FDesignedFakeForm.BorderStyle := bsNone
130 else if Sender = miSingle then
131 FDesignedFakeForm.BorderStyle := bsSingle
132 else if Sender = miSizeable then
133 FDesignedFakeForm.BorderStyle := bsSizeable
134 else if Sender = miDialog then
135 FDesignedFakeForm.BorderStyle := bsDialog
136 else if Sender = miToolWindow then
137 FDesignedFakeForm.BorderStyle := bsToolWindow
138 else if Sender = miSizeToolWin then
139 FDesignedFakeForm.BorderStyle := bsSizeToolWin
140 ;
141
142 GlobalDesignHook.Modified(Self);
143 if not RootIsSelected then
144 RefreshValues
145 else
146 GlobalDesignHook.RefreshPropertyValues;
147 end;
148
149 procedure TfrFakeFormBackground.miRemoveClick(Sender: TObject);
150 begin
151 if pmBorderIcons.Tag = PtrInt(bHelp) then
152 FDesignedFakeForm.BorderIcons:=FDesignedFakeForm.BorderIcons - [biHelp]
153 else if pmBorderIcons.Tag = PtrInt(bMaximalize) then
154 FDesignedFakeForm.BorderIcons:=FDesignedFakeForm.BorderIcons - [biMaximize]
155 else if pmBorderIcons.Tag = PtrInt(bMinimalize) then
156 FDesignedFakeForm.BorderIcons:=FDesignedFakeForm.BorderIcons - [biMinimize]
157 else if pmBorderIcons.Tag = PtrInt(bSystem) then
158 FDesignedFakeForm.BorderIcons:=FDesignedFakeForm.BorderIcons - [biSystemMenu];
159
160 GlobalDesignHook.Modified(Self);
161 if not RootIsSelected then
162 RefreshValues
163 else
164 GlobalDesignHook.RefreshPropertyValues;
165 end;
166
167 procedure TfrFakeFormBackground.pmBorderIconsPopup(Sender: TObject);
168 begin
169 miRemove.Visible := pmBorderIcons.Tag <> PtrInt(bOther);
170 miLine.Visible := (pmBorderIcons.Tag <> PtrInt(bOther)) and (not bHelp.Visible or not bMinimalize.Visible or
171 not bMaximalize.Visible or not bSystem.Visible);
172 miAddHelp.Visible := not bHelp.Visible;
173 miAddMinimize.Visible := not bMinimalize.Visible;
174 miAddMaximize.Visible := not bMaximalize.Visible;
175 miAddSystemMenu.Visible := not bSystem.Visible;
176 end;
177
TfrFakeFormBackground.RootIsSelectednull178 function TfrFakeFormBackground.RootIsSelected: Boolean;
179 var
180 LSelection: TPersistentSelectionList;
181 i: integer;
182 begin
183 Result := False;
184 LSelection := TPersistentSelectionList.Create;
185 GlobalDesignHook.GetSelection(LSelection);
186 for i := 0 to LSelection.Count - 1 do
187 if LSelection.Items[i] = FDesignedForm.Form then
188 begin
189 Result := True;
190 Break;
191 end;
192 LSelection.Free;
193 end;
194
195 procedure TfrFakeFormBackground.bIconClick(Sender: TObject);
196 begin
197 pmFormStyle.PopUp(Mouse.CursorPos.x, Mouse.CursorPos.y);
198 end;
199
200 procedure TfrFakeFormBackground.bFormCaptionClick(Sender: TObject);
201 begin
202 eFormCaption.Visible := True;
203 eFormCaption.SetFocus;
204 end;
205
206 procedure TfrFakeFormBackground.bOtherClick(Sender: TObject);
207 begin
208 pmBorderIcons.Tag := PtrInt(Sender);
209 pmBorderIcons.PopUp(Mouse.CursorPos.x, Mouse.CursorPos.y);
210 end;
211
212 procedure TfrFakeFormBackground.bResizeClick(Sender: TObject);
213 begin
214 case FDesignedFakeForm.BorderStyle of
215 bsSizeable: miNoneClick(miSingle);
216 bsSingle: miNoneClick(miSizeable);
217 bsToolWindow: miNoneClick(miSizeToolWin);
218 bsSizeToolWin: miNoneClick(miToolWindow);
219 end;
220 end;
221
222 procedure TfrFakeFormBackground.eFormCaptionExit(Sender: TObject);
223 begin
224 bFormCaption.Caption := eFormCaption.Text;
225 eFormCaption.Visible := False;
226 FDesignedFakeForm.Caption := eFormCaption.Text;
227 GlobalDesignHook.Modified(Self);
228 GlobalDesignHook.RefreshPropertyValues;
229 end;
230
231 procedure TfrFakeFormBackground.eFormCaptionKeyDown(Sender: TObject;
232 var Key: Word; Shift: TShiftState);
233 begin
234 if Key = VK_RETURN then
235 eFormCaptionExit(eFormCaption);
236 end;
237
GetMarginnull238 function TfrFakeFormBackground.GetMargin(const AIndex: Integer): Integer;
239 begin
240 case AIndex of
241 0: // left
242 Result := 5;
243 1: // Top
244 Result := 30;
245 2: // Right
246 Result := 5;
247 3: // Bottom
248 Result := 5;
249 end;
250 end;
251
252 procedure TfrFakeFormBackground.OnUserInputHandler(Sender: TObject; Msg: Cardinal);
253 var
254 LCtrl: TControl;
255 LIDE: IDesignedFormIDE;
256 begin
257 LIDE := FDesignedForm as IDesignedFormIDE;
258 if LIDE.LastActiveSourceWindow = nil then
259 Exit;
260
261 if FindModulePageControl(LIDE.LastActiveSourceWindow).PageIndex <> 1 then
262 Exit;
263
264 LCtrl := FindDragTarget(Mouse.CursorPos, True);
265 if eFormCaption.Visible and (LCtrl <> eFormCaption) then
266 eFormCaptionExit(eFormCaption);
267 end;
268
269 procedure TfrFakeFormBackground.OnDesignRefreshPropertyValues;
270 begin
271 if RootIsSelected then
272 RefreshValues;
273 end;
274
GetParentnull275 function TfrFakeFormBackground.GetParent: TWinControl;
276 begin
277 Result := inherited Parent;
278 end;
279
280 procedure TfrFakeFormBackground.SetParent(AParent: TWinControl);
281 begin
282 inherited SetParent(AParent);
283 UpdateBorderIcons;
284 UpdateCaption;
285 end;
286
GetDesignedFormnull287 function TfrFakeFormBackground.GetDesignedForm: IDesignedForm;
288 begin
289 Result := FDesignedForm as IDesignedForm;
290 end;
291
TfrFakeFormBackground.GetResizeFramenull292 function TfrFakeFormBackground.GetResizeFrame: IResizeFrame;
293 begin
294 Result := nil;
295 end;
296
297 procedure TfrFakeFormBackground.SetResizeFrame(AValue: IResizeFrame);
298 begin
299 end;
300
301 constructor TfrFakeFormBackground.Create(const ADesignedForm: IDesignedForm;
302 const ADesignedFakeForm: IDesignedFakeForm);
303 begin
304 inherited Create(nil);
305 FDesignedForm := ADesignedForm;
306 FDesignedFakeForm := ADesignedFakeForm;
307 Frames.Add(Self);
308
309 GlobalDesignHook.AddHandlerRefreshPropertyValues(@OnDesignRefreshPropertyValues);
310 RefreshValues;
311 end;
312
313 destructor TfrFakeFormBackground.Destroy;
314 begin
315 Pointer(FDesignedForm) := nil;
316 Pointer(FDesignedFakeForm) := nil;
317 Frames.Remove(Self);
318 GlobalDesignHook.RemoveHandlerRefreshPropertyValues(@OnDesignRefreshPropertyValues);
319 inherited Destroy;
320 end;
321
322 procedure TfrFakeFormBackground.RefreshValues;
323
324 procedure SetBorderStyle({ABorderStyle: TBGRABorderStyle});
325 begin
326 {bBackground.BorderStyle.BottomLeft:=ABorderStyle;
327 bBackground.BorderStyle.BottomRight:=ABorderStyle;
328 bBackground.BorderStyle.TopLeft:=ABorderStyle;
329 bBackground.BorderStyle.TopRight:=ABorderStyle; }
330 end;
331
332 procedure LoadPng(ABitmap: TCustomBitmap; AName: string);
333 var
334 LPng: TPortableNetworkGraphic;
335 begin
336 LPng := TPortableNetworkGraphic.Create;
337 LPng.LoadFromResourceName(HINSTANCE, AName);
338 ABitmap.Assign(LPng);
339 LPng.Free;
340 end;
341
342 procedure SelectFormStyle(AMenuItem: TMenuItem);
343 begin
344 miNone.Checked:=False;
345 miSingle.Checked:=False;
346 miSizeable.Checked:=False;
347 miDialog.Checked:=False;
348 miToolWindow.Checked:=False;
349 miSizeToolWin.Checked:=False;
350 AMenuItem.Checked:=True;
351 end;
352
353 begin
354 UpdateBorderIcons;
355 UpdateCaption;
356
357 if FDesignedFakeForm.BorderStyle in [bsSizeable, bsSizeToolWin] then
358 LoadPng(bResize.Picture.Bitmap, 'form_bg_resize')
359 else
360 LoadPng(bResize.Picture.Bitmap, 'form_bg_noresize');
361
362 case FDesignedFakeForm.BorderStyle of
363 bsToolWindow, bsSizeToolWin: SetBorderStyle({bsSquare});
364 bsSingle, bsSizeable, bsNone: SetBorderStyle({bsRound});
365 bsDialog: SetBorderStyle({bsBevel});
366 end;
367
368 case FDesignedFakeForm.BorderStyle of
369 bsToolWindow: SelectFormStyle(miToolWindow);
370 bsSizeToolWin: SelectFormStyle(miSizeToolWin);
371 bsSingle: SelectFormStyle(miSingle);
372 bsSizeable:SelectFormStyle(miSizeable);
373 bsNone: SelectFormStyle(miNone);
374 bsDialog: SelectFormStyle(miDialog);
375 end;
376
377 bTop.Visible := FDesignedFakeForm.BorderStyle = bsNone;
378 bBackground.Visible := FDesignedFakeForm.BorderStyle <> bsNone;
379 end;
380
381 procedure TfrFakeFormBackground.UpdateBorderIcons;
382 begin
383 if FDesignedFakeForm = nil then
384 Exit;
385
386 bOther.Visible := (FDesignedFakeForm.BorderIcons * [biSystemMenu, biMinimize, biMaximize, biHelp]) = [];
387 bHelp.Visible := biHelp in FDesignedFakeForm.BorderIcons;
388 bMinimalize.Visible := biMinimize in FDesignedFakeForm.BorderIcons;
389 bMaximalize.Visible := biMaximize in FDesignedFakeForm.BorderIcons;
390 bSystem.Visible := biSystemMenu in FDesignedFakeForm.BorderIcons;
391 end;
392
393 procedure TfrFakeFormBackground.UpdateCaption;
394 begin
395 if FDesignedFakeForm = nil then
396 Exit;
397
398 bFormCaption.Caption := FDesignedFakeForm.Caption;
399 eFormCaption.Caption := FDesignedFakeForm.Caption;
400 end;
401
402 type
403
404 { OnUserInputHandler }
405
406 TOnUserInputHandler = class
407 public
408 class procedure OnUserInputHandler(Sender: TObject; Msg: Cardinal);
409 end;
410
411 { OnUserInputHandler }
412
413 class procedure TOnUserInputHandler.OnUserInputHandler(Sender: TObject; Msg: Cardinal);
414 var
415 p: pointer;
416 frame: TfrFakeFormBackground absolute p;
417 begin
418 case Msg of
419 LM_LBUTTONDOWN, LM_RBUTTONDOWN, LM_MBUTTONDOWN, LM_XBUTTONDOWN:
420 for p in Frames do
421 if frame.Parent <> nil then // jesli robilismy popupparent framesy sie tworzyly i byl przypisywany zly caption
422 frame.OnUserInputHandler(Sender, Msg);
423 end;
424 end;
425
426 var
427 OnUserInputHandler: TOnUserInputHandler;
428 initialization
429 Frames := TList.Create;
430 Application.AddOnUserInputHandler(@OnUserInputHandler.OnUserInputHandler);
431 finalization
432 Application.RemoveOnUserInputHandler(@OnUserInputHandler.OnUserInputHandler);
433 Frames.Free;
434 end.
435
436