1
2 {*****************************************}
3 { }
4 { FastReport v2.3 }
5 { Tool controls }
6 { }
7 { Copyright (c) 1998-99 by Tzyganenko A. }
8 { }
9 {*****************************************}
10
11 unit LR_Dock;
12
13 interface
14
15 {$I LR_Vers.inc}
16
17 uses
18 Classes, SysUtils, LResources,LMessages,Messages,
19 Forms, Controls, Graphics, Dialogs,
20 ExtCtrls, Buttons, StdCtrls,Menus,
21
22 GraphType,LCLType,LCLIntf,LCLProc,
23
24 LR_Fpc;
25
26 type
27 TfrOrientation = (toAny, toVertOnly, toHorzOnly);
28
29 TfrFloatWindow = class;
30
31 TfrDock = class(TPanel)
32 private
33 FRowSize: Integer;
34 protected
35 procedure Loaded; override;
36 public
37 constructor Create(AOwner: TComponent); override;
38 procedure AdjustBounds;
39 procedure Paint; override;
40 published
41 property RowSize: Integer read FRowSize write FRowSize default 26;
42 end;
43
44 TfrDragBox = class(TGraphicControl)
45 protected
46 procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
47 X, Y: Integer); override;
48 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
49 procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
50 X, Y: Integer); override;
51 public
52 constructor Create(AOwner: TComponent); override;
53 procedure Paint; override;
54 end;
55
56 TfrToolBar = class(TPanel)
57 private
58 FDragBox: TfrDragBox;
59 FWindow: TfrFloatWindow;
60 FIsFloat: Boolean;
61 FDown: Boolean;
62 FLastX, FLastY: Integer;
63 FOrientation: TfrOrientation;
64 FCanFloat: Boolean;
ParentAlignnull65 function ParentAlign: TAlign;
FindDocknull66 function FindDock(AOwner: TWinControl; p: TPoint): Boolean;
67 procedure MakeFloat;
MoveTonull68 function MoveTo(X, Y: Integer): Boolean;
GetVisiblenull69 function GetVisible: Boolean;
70 procedure SetVisible(Value: Boolean);
71 procedure DockTo(aDock: TfrDock; X, Y: Integer);
72 procedure FloatTo(X,Y: Integer);
73 procedure DoMouseDown(Sender: TObject; Button: TMouseButton;
74 Shift: TShiftState; X, Y: Integer);
75 procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X,
76 Y: Integer);
77 procedure DoMouseUp(Sender: TObject; Button: TMouseButton;
78 Shift: TShiftState; X, Y: Integer);
79 procedure DoResize(Sender: TObject);
80 procedure WMWindowPosChanged(var Message: TLMWindowPosChanged); message LM_WINDOWPOSCHANGED;
GetFloatWindownull81 function GetFloatWindow: TForm;
82 protected
83 procedure Loaded; override;
84 procedure RealignControls;
GetClientRectnull85 function GetClientRect: TRect; override;
86 public
87 constructor Create(AOwner: TComponent); override;
88 destructor Destroy; override;
89 procedure Paint; override;
90 procedure AdjustBounds;
91 procedure AddToDock(aDock: TfrDock);
92 property IsFloat: Boolean read FIsFloat;
93 property FloatWindow: TForm read GetFloatWindow;
94 property IsVisible: Boolean read GetVisible write SetVisible;
95 published
96 property CanFloat: Boolean read FCanFloat write FCanFloat default True;
97 property Orientation: TfrOrientation read FOrientation write FOrientation;
98 end;
99
100 TfrFloatWindow = class(TForm)
101 procedure FormShow(Sender: TObject);
102 procedure FormDestroy(Sender: TObject);
103 private
104 FRect: TRect;
105 FDown: Boolean;
106 procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
107 protected
108 procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
109 X, Y: Integer); override;
110 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
111 procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
112 X, Y: Integer); override;
113 public
114 ToolBar: TfrToolBar;
115 procedure Capture;
116 end;
117
118 var
119 RegRootKey: String;
120
121 const
122 rsToolBar = 'ToolBar\';
123 rsForm = 'Form\';
124 rsWidth = 'Width';
125 rsHeight = 'Height';
126 rsTop = 'Top';
127 rsLeft = 'Left';
128 rsFloat = 'isFloat';
129 rsVisible = 'isVisible';
130 rsX = 'XPosition';
131 rsY = 'YPosition';
132 rsDockName = 'DockName';
133
134 procedure SaveToolbarPosition(t: TfrToolBar);
135 procedure RestoreToolbarPosition(t: TfrToolBar);
136 procedure SaveFormPosition(f: TForm);
137 procedure RestoreFormPosition(f: TForm);
138
139 procedure Register;
140
141 implementation
142
143 {$R *.lfm}
144
145 uses Registry;
146
147 var
148 FloatingToolBars: TFpList;
149
150
151 procedure AddToToolbarList(t: TfrToolBar);
152 begin
153 if FloatingToolbars.IndexOf(t) <> -1 then
154 FloatingToolbars.Add(t);
155 end;
156
157 procedure RemoveFromToolbarList(t: TfrToolBar);
158 var
159 i: Integer;
160 begin
161 i := FloatingToolbars.IndexOf(t);
162 if i <> -1 then
163 FloatingToolbars.Delete(i);
164 end;
165
166 procedure DestroyToolbarList;
167 var
168 i: Integer;
169 begin
170 for i := 0 to FloatingToolBars.Count-1 do
171 TfrToolBar(FloatingToolBars[i]).Free;
172 end;
173
174
175 procedure SaveToolbarPosition(t: TfrToolBar);
176 var
177 Ini: TRegIniFile;
178 X, Y: integer;
179 Name: String;
180 begin
181 Ini := TRegIniFile.Create(RegRootKey);
182 Name := rsToolbar + t.Name;
183 Ini.WriteBool(Name, rsFloat, t.isFloat);
184 Ini.WriteBool(Name, rsVisible, t.IsVisible);
185 X := t.Left; Y := t.Top;
186 if t.IsFloat then
187 begin
188 X := t.FloatWindow.Left; Y := t.FloatWindow.Top;
189 end;
190 Ini.WriteInteger(Name, rsX, X);
191 Ini.WriteInteger(Name, rsY, Y);
192 Ini.WriteInteger(Name, rsWidth, t.Width);
193 Ini.WriteInteger(Name, rsHeight, t.Height);
194 if t.Parent is TfrDock then
195 Ini.WriteString(Name, rsDockName, t.Parent.Name);
196 Ini.Free;
197 end;
198
199 procedure RestoreToolbarPosition(t: TfrToolBar);
200 var
201 Ini: TRegIniFile;
202 X, Y: Integer;
203 DN: string;
204 NewDock: TfrDock;
205 Name: String;
206 begin
207 Ini := TRegIniFile.Create(RegRootKey);
208 Name := rsToolbar + t.Name;
209 t.IsVisible := False;
210 X := Ini.ReadInteger(Name, rsX, t.Left);
211 Y := Ini.ReadInteger(Name, rsY, t.Top);
212 t.Width := Ini.ReadInteger(Name, rsWidth, t.Width);
213 t.Height := Ini.ReadInteger(Name, rsHeight, t.Height);
214 if Ini.ReadBool(Name, rsFloat, False) then
215 t.FloatTo(X, Y)
216 else
217 begin
218 t.Left := X;
219 t.Top := Y;
220 DN := Ini.ReadString(Name, rsDockName, t.Parent.Name);
221 if (t.Owner <> nil) then
222 begin
223 NewDock := t.Owner.FindComponent(DN) as TfrDock;
224 if (NewDock <> nil) and (NewDock <> t.Parent) then
225 t.DockTo(NewDock, X, Y);
226 end;
227 t.AdjustBounds;
228 end;
229 t.IsVisible := Ini.ReadBool(Name, rsVisible, True);
230 Ini.Free;
231 end;
232
233 procedure SaveFormPosition(f: TForm);
234 var
235 Ini: TRegIniFile;
236 Name: String;
237 begin
238 Ini := TRegIniFile.Create(RegRootKey);
239 Name := rsForm + f.Name;
240 Ini.WriteBool(Name, rsVisible, f.Visible);
241 Ini.WriteInteger(Name, rsX, f.Left);
242 Ini.WriteInteger(Name, rsY, f.Top);
243 Ini.WriteInteger(Name, rsWidth, f.Width);
244 Ini.WriteInteger(Name, rsHeight, f.Height);
245 Ini.Free;
246 end;
247
248 procedure RestoreFormPosition(f: TForm);
249 var
250 Ini: TRegIniFile;
251 Name: String;
252 begin
253 Ini := TRegIniFile.Create(RegRootKey);
254 Name := rsForm + f.Name;
255 f.Hide;
256 f.Left := Ini.ReadInteger(Name, rsX, f.Left);
257 f.Top := Ini.ReadInteger(Name, rsY, f.Top);
258 f.Width := Ini.ReadInteger(Name, rsWidth, f.Width);
259 f.Height := Ini.ReadInteger(Name, rsHeight, f.Height);
260 if Ini.ReadBool(Name, rsVisible, True) then
261 f.Show;
262 Ini.Free;
263 end;
264
265
266 {--------------------------------------------------------------------------}
267 constructor TfrDock.Create(AOwner: TComponent);
268 begin
269 inherited Create(AOwner);
270 RowSize := 26;
271 end;
272
273 procedure TfrDock.Loaded;
274 begin
275 inherited Loaded;
276 AdjustBounds;
277 end;
278
279 procedure TfrDock.AdjustBounds;
280 var
281 i, Line, LineCount, l, dl: Integer;
282 CtlOnLine, NewSize: Integer;
283 c: TControl;
284 ShiftNeeded: Boolean;
285 begin
286 if ControlCount = 0 then
287 begin
288 if Align in [alTop, alBottom] then
289 Height := 1 else
290 Width := 1;
291 Exit;
292 end;
293 if Align in [alTop, alBottom] then
294 L := Height else
295 L := Width;
296 LineCount := L div RowSize;
297 NewSize := RowSize * LineCount + 1;
298 L := 0;
299 dL := RowSize;
300 if Align in [alRight, alBottom] then
301 begin
302 dL := -RowSize;
303 if Align = alRight then
304 L := Width else
305 L := Height;
306 end;
307 Line := 0;
308 while Line < LineCount do
309 begin
310 CtlOnLine := 0;
311 for i := 0 to ControlCount-1 do
312 begin
313 c := Controls[i];
314 if c.Visible then
315 case Align of
316 alLeft:
317 if (c.Left = L) or
318 ((c.Left < L) and (c.Left + c.Width > L)) then Inc(CtlOnLine);
319 alRight:
320 if (c.Left + c.Width = L) or
321 ((c.Left + c.Width > L) and (c.Left < L)) then Inc(CtlOnLine);
322 alTop:
323 if (c.Top = L) or
324 ((c.Top < L) and (c.Top + c.Height > L)) then Inc(CtlOnLine);
325 alBottom:
326 if (c.Top + c.Height = L) or
327 ((c.Top + c.Height > L) and (c.Top < L)) then Inc(CtlOnLine);
328 end;
329 end;
330 if CtlOnLine = 0 then
331 begin
332 for i := 0 to ControlCount-1 do
333 begin
334 c := Controls[i];
335 if c.Visible then
336 begin
337 if ((Align = alLeft) and (c.Left > L)) or
338 ((Align = alRight) and (c.Left + c.Width > L)) then
339 c.Left := c.Left - RowSize;
340 if ((Align = alTop) and (c.Top > L)) or
341 ((Align = alBottom) and (c.Top + c.Height > L)) then
342 c.Top := c.Top - RowSize;
343 end;
344 end;
345 Dec(NewSize, RowSize);
346 Dec(LineCount);
347 Dec(Line);
348 if Align in [alTop, alLeft] then Dec(L, dL);
349 end;
350 Inc(Line);
351 Inc(L, dL);
352 end;
353
354 ShiftNeeded := False;
355 for i := 0 to ControlCount-1 do
356 begin
357 c := Controls[i];
358 if c.Visible then
359 begin
360 if (Align = alRight) and (c.Left < 0) then
361 begin
362 ShiftNeeded := True;
363 L := -c.Left + 1;
364 Inc(NewSize, L);
365 break;
366 end;
367 if (Align = alBottom) and (c.Top < 0) then
368 begin
369 ShiftNeeded := True;
370 L := -c.Top + 1;
371 Inc(NewSize, L);
372 break;
373 end;
374 if (Align = alTop) and (c.Top + c.Height > NewSize) then
375 begin
376 NewSize := c.Top + c.Height + 1;
377 break;
378 end;
379 if (Align = alLeft) and (c.Left + c.Width > NewSize) then
380 begin
381 NewSize := c.Left + c.Width + 1;
382 break;
383 end;
384 end;
385 end;
386 if ShiftNeeded then
387 for i := 0 to ControlCount-1 do
388 begin
389 c := Controls[i];
390 if c.Visible then
391 if Align = alRight then
392 c.Left := c.Left + L
393 else if Align = alBottom then
394 c.Top := c.Top + L;
395 end;
396
397 for i := 0 to ControlCount-1 do
398 begin
399 c := Controls[i];
400 if c.Visible then
401 begin
402 if (Align = alRight) and (c.Left + c.Width > NewSize) then
403 NewSize := c.Left + c.Width;
404 if (Align = alBottom) and (c.Top + c.Height > NewSize) then
405 NewSize := c.Top + c.Height;
406 end;
407 end;
408
409 case Align of
410 alTop: Height := NewSize;
411 alLeft: Width := NewSize;
412 alBottom:
413 if Height < NewSize then
414 SetBounds(0, Top - (NewSize - Height), Width, NewSize)
415 else
416 Height := NewSize;
417 alRight:
418 if Width < NewSize then
419 SetBounds(Left - (NewSize - Width), Top, NewSize, Height)
420 else
421 Width := NewSize;
422 end;
423 end;
424
425 procedure TfrDock.Paint;
426 var
427 R: TRect;
428 begin
429 with Canvas do
430 begin
431 Brush.Color := clBtnFace;
432 R := Rect(0, 0, Width, Height);
433 FillRect(R);
434 if csDesigning in ComponentState then
435 begin
436 Pen.Color := clBtnShadow;
437 Rectangle(0, 0, Width, Height);
438 end;
439 end;
440 end;
441
442
443 {--------------------------------------------------------------------------}
444 constructor TfrDragBox.Create(AOwner: TComponent);
445 begin
446 inherited Create(AOwner);
447 Width := 11;
448 Height := 11;
449 end;
450
451 procedure TfrDragBox.Paint;
452 var
453 R: TRect;
454 begin
455 with Canvas do
456 begin
457 Brush.Color := clBtnFace;
458 R := Rect(0, 0, Width, Height);
459 FillRect(R);
460 end;
461 if (Parent as TfrToolBar).ParentAlign = alTop then
462 begin
463 R := Rect(2, 0, 5, Height);
464 Frame3D(Canvas, R, clBtnHighlight, clBtnShadow,1);
465 R := Rect(5, 0, 8, Height);
466 Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
467 end
468 else if (Parent as TfrToolBar).ParentAlign = alLeft then
469 begin
470 R := Rect(0, 2, Width, 5);
471 Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
472 R := Rect(0, 5, Width, 8);
473 Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
474 end;
475 end;
476
477 procedure TfrDragBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
478 X, Y: Integer);
479 var
480 p: TPoint;
481 begin
482 p := ClientToScreen(Point(X, Y));
483 p := Parent.ScreenToClient(p);
484 (Parent as TfrToolBar).DoMouseDown(Self, Button, Shift, P.X, P.Y);
485 end;
486
487 procedure TfrDragBox.MouseMove(Shift: TShiftState; X, Y: Integer);
488 var
489 p: TPoint;
490 begin
491 p := ClientToScreen(Point(X, Y));
492 p := Parent.ScreenToClient(p);
493 (Parent as TfrToolBar).DoMouseMove(Self, Shift, P.X, P.Y);
494 end;
495
496 procedure TfrDragBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
497 X, Y: Integer);
498 var
499 p: TPoint;
500 begin
501 p := ClientToScreen(Point(X, Y));
502 p := Parent.ScreenToClient(p);
503 (Parent as TfrToolBar).DoMouseUp(Self, Button, Shift, P.X, P.Y);
504 end;
505
506
507 {--------------------------------------------------------------------------}
508 constructor TfrToolBar.Create(AOwner: TComponent);
509 begin
510 inherited Create(AOwner);
511 Height := 26;
512 FDragBox := TfrDragBox.Create(Self);
513 FDragBox.Parent := Self;
514 FDragBox.Align := alLeft;
515 FullRepaint := False;
516 OnMouseDown := @DoMouseDown;
517 OnMouseMove := @DoMouseMove;
518 OnMouseUp := @DoMouseUp;
519 OnResize := @DoResize;
520 FCanFloat := True;
521 FOrientation := toAny;
522 end;
523
524 destructor TfrToolBar.Destroy;
525 begin
526 FDragBox.Free;
527 if FWindow <> nil then
528 begin
529 Parent := nil;
530 FWindow.Hide;
531 FWindow.Free;
532 end;
533 inherited Destroy;
534 end;
535
536 procedure TfrToolBar.Loaded;
537 begin
538 inherited Loaded;
539 AdjustBounds;
540 end;
541
542 procedure TfrToolBar.Paint;
543 var
544 R: TRect;
545 begin
546 with Canvas do
547 begin
548 Brush.Color := clBtnFace;
549 R := Rect(0, 0, Width, Height);
550 FillRect(R);
551 if not IsFloat then
552 LR_Fpc.Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
553 end;
554 end;
555
TfrToolBar.ParentAlignnull556 function TfrToolBar.ParentAlign: TAlign;
557 begin
558 Result := Parent.Align;
559 if Result = alBottom then Result := alTop;
560 if Result = alRight then Result := alLeft;
561 end;
562
GetClientRectnull563 function TfrToolBar.GetClientRect: TRect;
564 begin
565 Result := inherited GetClientRect;
566 InflateRect(Result, -1, -1);
567 end;
568
TfrToolBar.GetVisiblenull569 function TfrToolBar.GetVisible: Boolean;
570 begin
571 if IsFloat then
572 Result := FWindow.Visible else
573 Result := Visible;
574 end;
575
576 procedure TfrToolBar.SetVisible(Value: Boolean);
577 begin
578 if IsFloat then
579 FWindow.Visible := Value else
580 Visible := Value;
581 end;
582
583 procedure TfrToolBar.DockTo(aDock: TfrDock; X, Y: Integer);
584 var
585 oldParent: TfrDock;
586 begin
587 Hide;
588 if FWindow <> nil then
589 begin
590 FWindow.Hide;
591 FWindow.Release;
592 Parent := nil;
593 end;
594 FWindow := nil;
595 oldParent := nil;
596 if (Parent <> nil) and (Parent is TfrDock) then
597 oldParent := Parent as TfrDock;
598 Parent := aDock;
599 if oldParent <> nil then
600 oldParent.AdjustBounds;
601 FIsFloat := False;
602 FDragBox.Show;
603 RealignControls;
604 Left := X; Top := Y;
605 Show;
606 aDock.AdjustBounds;
607 RemoveFromToolbarList(Self);
608 end;
609
610 procedure TfrToolBar.AddToDock(aDock: TfrDock);
611 var
612 X,Y: Integer;
613 begin
614 X := 0;
615 Y := 0;
616 case aDock.Align of
617 alTop:
618 begin
619 X := 0;
620 Y := aDock.Height - 1;
621 end;
622 alBottom:
623 begin
624 X := 0;
625 Y := -Height + 1;
626 end;
627 alLeft:
628 begin
629 X := aDock.Width - 1;
630 Y := 0;
631 end;
632 alRight:
633 begin
634 X := -Width + 1;
635 Y := 0;
636 end;
637 end;
638 DockTo(aDock, X, Y);
639 end;
640
TfrToolBar.FindDocknull641 function TfrToolBar.FindDock(AOwner: TWinControl; p: TPoint): Boolean;
642 var
643 i: Integer;
644 c: TControl;
645 d: TfrDock;
646 begin
647 Result := False;
648 for i := 0 to AOwner.ControlCount-1 do
649 begin
650 c := AOwner.Controls[i];
651 if c is TfrDock then
652 if (p.X >= c.Left) and (p.X <= c.Left + c.Width) and
653 (p.Y >= c.Top) and (p.Y <= c.Top + c.Height) then
654 begin
655 with c as TfrDock do
656 if ((FOrientation = toHorzOnly) and (Align in [alLeft, alRight])) or
657 ((FOrientation = toVertOnly) and (Align in [alTop, alBottom])) then
658 break;
659 d := c as TfrDock;
660 if d.Align in [alTop,alBottom] then
661 begin
662 p := Point(p.X - d.Left, d.Height - 1);
663 if p.X + Width > d.Width then
664 p.X := d.Width - Width;
665 if p.X < 0 then p.X := 0;
666 if d.Align = alBottom then
667 p.Y := -Height + 1;
668 end
669 else
670 begin
671 p := Point(d.Width - 1, p.Y - d.Top);
672 if p.Y + Height > d.Height then
673 p.Y := d.Height - Height;
674 if p.Y < 0 then p.Y := 0;
675 if d.Align = alRight then
676 p.X := -Height + 1;
677 end;
678 DockTo(d, p.X, p.Y);
679 SetCaptureControl(Self);
680 DoMouseDown(Self, mbLeft, [], 0, 0);
681 Result := True;
682 break;
683 end;
684 end;
685 end;
686
687 procedure TfrToolBar.RealignControls;
688 var
689 i, j, t: Integer;
690 TempCtrl: TControl;
691 Ctrls: Array[0..100] of TControl;
692 begin
693 for i := 0 to ControlCount-1 do
694 Ctrls[i] := Controls[i];
695 for i := 0 to ControlCount-1 do
696 for j := 0 to ControlCount-2 do
697 if Parent.Align in [alTop, alBottom, alNone] then
698 begin
699 if Ctrls[j].Left > Ctrls[j + 1].Left then
700 begin
701 TempCtrl := Ctrls[j + 1];
702 Ctrls[j + 1] := Ctrls[j];
703 Ctrls[j] := TempCtrl;
704 end;
705 end
706 else
707 begin
708 if (Ctrls[j].Align in [alTop, alBottom]) and
709 (Ctrls[j + 1].Align in [alTop, alBottom]) and
710 (Ctrls[j].Top > Ctrls[j + 1].Top) then
711 begin
712 TempCtrl := Ctrls[j];
713 Ctrls[j] := Ctrls[j + 1];
714 Ctrls[j + 1] := TempCtrl;
715 end;
716 end;
717 case Parent.Align of
718 alTop, alBottom, alNone:
719 begin
720 if Height > Width then
721 begin
722 t := Width;
723 Width := Height;
724 Height := t;
725 end;
726 for t := 0 to ControlCount-1 do
727 if Ctrls[t] <> nil then
728 if not (Ctrls[t].Align in [alLeft, alRight]) then
729 if (Ctrls[t].Align = alBottom) then
730 Ctrls[t].Align := alRight
731 else
732 begin
733 Ctrls[t].Left := Ctrls[t].Top;
734 Ctrls[t].Align := alLeft;
735 end;
736 end;
737 alLeft, alRight:
738 begin
739 if Width > Height then
740 begin
741 t := Width;
742 Width := Height;
743 Height := t;
744 end;
745 for t := 0 to ControlCount-1 do
746 if Ctrls[t] <> nil then
747 if not (Ctrls[t].Align in [alTop, alBottom]) then
748 if (Ctrls[t].Align = alRight) then
749 Ctrls[t].Align := alBottom
750 else
751 begin
752 Ctrls[t].Top := Ctrls[t].Left;
753 Ctrls[t].Align := alTop;
754 end;
755 end;
756 end;
757 end;
758
759 procedure TfrToolBar.AdjustBounds;
760 var
761 i, max: Integer;
762 c: TControl;
763 begin
764 RealignControls;
765 max := 0;
766 for i := 0 to ControlCount-1 do
767 begin
768 c := Controls[i];
769 if Parent.Align in [alTop, alBottom, alNone] then
770 Inc(max, c.Width)
771 else
772 Inc(max, c.Height);
773 end;
774 if Parent.Align in [alTop, alBottom, alNone] then
775 Width := max + 4 else
776 Height := max + 4;
777 end;
778
779 procedure TfrToolBar.MakeFloat;
780 var
781 p: TPoint;
782 begin
783 FIsFloat := True;
784 GetCursorPos(p);
785 FloatTo(p.X, p.Y);
786 FWindow.Capture;
787 end;
788
789 procedure TfrToolBar.FloatTo(X, Y: Integer);
790 var
791 oldParent: TfrDock;
792 begin
793 FIsFloat := True;
794 if FWindow = nil then
795 begin
796 oldParent := nil;
797 if (Parent <> nil) and (Parent is TfrDock) then
798 oldParent := Parent as TfrDock;
799 Hide;
800 FDragBox.Visible:=False;
801 FWindow := TfrFloatWindow.Create(GetParentForm(Self));
802 FWindow.BorderStyle := bsToolWindow;
803 FWindow.Left := X;
804 FWindow.Top := Y;
805 FWindow.Caption := Caption;
806 FWindow.FormStyle := fsStayOnTop;
807 Parent := FWindow;
808 RealignControls;
809 if oldParent <> nil then
810 oldParent.AdjustBounds;
811 FWindow.ClientWidth := Width - 11;
812 FWindow.ClientHeight := Height;
813 FWindow.ToolBar := Self;
814 Left := 0; Top := 0;
815 Show;
816 AddToToolbarList(Self);
817 end
818 else
819 FWindow.SetBounds(X, Y, FWindow.Width, FWindow.Height);
820 end;
821
MoveTonull822 function TfrToolBar.MoveTo(X, Y: Integer): Boolean;
823 var
824 i, n, oldSize, ShiftCount: Integer;
825 c: TControl;
826
827 procedure Shift(ax,ay:Integer);
828 begin
829 x := ax;
830 y := ay;
831 Inc(ShiftCount);
832 end;
833
834 begin
835 Result := True;
836 if IsFloat then Exit;
837 n := 0;
838 repeat
839 ShiftCount := 0;
840
841 if ParentAlign = alTop then
842 begin
843 if x < -20 then
844 FIsFloat := True;
845 if x < 0 then Shift(0, y);
846 if x + Width > Parent.Width then
847 Shift(Parent.Width - Width, y);
848 end
849 else // if ParentAlign = alLeft then
850 begin
851 if y < -20 then
852 FIsFloat := True;
853 if y < 0 then Shift(x, 0);
854 if y + Height > Parent.Height then
855 Shift(x, Parent.Height - Height);
856 end;
857
858 if not IsFloat then
859 for i := 0 to Parent.ControlCount-1 do
860 begin
861 c := Parent.Controls[i];
862 if (c <> Self) and c.Visible then
863 if ParentAlign = alTop then
864 begin
865 if ((y >= c.Top) and (y < c.Top + c.Height)) or
866 ((y <= c.Top) and (y + Height > c.Top)) then
867 begin
868 if (x >= c.Left) and (x < c.Left + c.Width) then
869 Shift(c.Left + c.Width, y);
870 if (x < c.Left) and (x + Width > c.Left) then
871 Shift(c.Left - Width, y);
872 end;
873 end
874 else // if ParentAlign = alLeft then
875 begin
876 if ((x >= c.Left) and (x < c.Left + c.Width)) or
877 ((x <= c.Left) and (x + Width > c.Left)) then
878 begin
879 if (y >= c.Top) and (y < c.Top + c.Height) then
880 Shift(x, c.Top + c.Height);
881 if (y < c.Top) and (y + Height > c.Top) then
882 Shift(x, c.Top - Height);
883 end;
884 end;
885 end;
886 Inc(n);
887 until (n > 3) or (ShiftCount = 0) or IsFloat;
888
889 if not FCanFloat then
890 FIsFloat := False;
891
892 if IsFloat then
893 MakeFloat
894 else
895 if n < 3 then
896 begin
897 {$IFDEF DebugLR}
898 DebugLn('n < 3');
899 {$ENDIF}
900 if ParentAlign = alTop then
901 if (y + Height > Parent.Height) or (y < 0) then
902 oldSize := Parent.Height else
903 oldSize := 0
904 else
905 if (x + Width > Parent.Width) or (x < 0) then
906 oldSize := Parent.Width else
907 oldSize := 0;
908 Left := x;
909 Top := y;
910 (Parent as TfrDock).AdjustBounds;
911 if FCanFloat then
912 if ((ParentAlign = alTop) and (Parent.Height = oldSize)) or
913 ((ParentAlign = alLeft) and (Parent.Width = oldSize)) then
914 MakeFloat;
915 end
916 else Result := False;
917 end;
918
919 procedure TfrToolBar.DoMouseDown(Sender: TObject; Button: TMouseButton;
920 Shift: TShiftState; X, Y: Integer);
921 var
922 p: TPoint;
923 begin
924 GetCursorPos(p);
925 FLastX := p.X; FLastY := p.Y;
926 FDown := True;
927 end;
928
929 procedure TfrToolBar.DoMouseMove(Sender: TObject; Shift: TShiftState; X,
930 Y: Integer);
931 var
932 p: TPoint;
933 dx, dy: Integer;
934 StepX, StepY: Integer;
935 b: Boolean;
936 begin
937 if IsFloat then
938 begin
939 Cursor := crDefault;
940 FDown := False;
941 Exit;
942 end;
943 if not FDown then Exit;
944 GetCursorPos(p);
945 if ParentAlign = alTop then
946 StepY := (Parent as TfrDock).RowSize else
947 StepY := 1;
948 if ParentAlign = alLeft then
949 StepX := (Parent as TfrDock).RowSize else
950 StepX := 1;
951 dx := (p.X - FLastX) div StepX * StepX;
952 dy := (p.Y - FLastY) div StepY * StepY;
953 b := False;
954 if (dx <> 0) or (dy <> 0) then
955 b := MoveTo(Left + dx, Top + dy);
956 if b then
957 begin
958 if dx <> 0 then FLastX := p.X;
959 if dy <> 0 then FLastY := p.Y;
960 end;
961 end;
962
963 procedure TfrToolBar.DoMouseUp(Sender: TObject; Button: TMouseButton;
964 Shift: TShiftState; X, Y: Integer);
965 begin
966 FDown := False;
967 end;
968
969 procedure TfrToolBar.DoResize(Sender: TObject);
970 begin
971 if csDestroying in ComponentState then Exit;
972 FDragBox.SetBounds(0, 0, 11, 11);
973 if ParentAlign = alTop then
974 FDragBox.Align := alLeft else
975 FDragBox.Align := alTop;
976 end;
977
978 procedure TfrToolBar.WMWindowPosChanged(var Message: TLMWindowPosChanged);
979 begin
980 if csDesigning in ComponentState then
981 inherited else
982 DefaultHandler(Message);
983 end;
984
TfrToolBar.GetFloatWindownull985 function TfrToolBar.GetFloatWindow: TForm;
986 begin
987 Result := FWindow;
988 end;
989
990
991 {----------------------------------------------------------------------------}
992 procedure DrawFrameRect(R: TRect);
993 var
994 DC: HDC;
995 i: Integer;
996 begin
997 DC := GetDC(0);
998 for i := 0 to 3 do
999 begin
1000 //**DrawFocusRect(DC, R);
1001 InflateRect(R, -1, -1);
1002 end;
1003 ReleaseDC(0, DC);
1004 end;
1005
1006 procedure TfrFloatWindow.Capture;
1007 begin
1008 SetCaptureControl(Self);
1009 MouseDown(mbLeft, [], 0, 0);
1010 end;
1011
1012 procedure TfrFloatWindow.WMNCHitTest(var Msg: TWMNCHitTest);
1013 begin
1014 inherited;
1015 if Msg.Result = htCaption then Msg.Result := htClient;
1016 end;
1017
1018 procedure TfrFloatWindow.MouseDown(Button: TMouseButton; Shift: TShiftState;
1019 X, Y: Integer);
1020 var
1021 p: TPoint;
1022 begin
1023 GetCursorPos(p);
1024 FRect := Rect(p.X, p.Y, p.X + Width, p.Y + Height);
1025 Application.ProcessMessages;
1026 DrawFrameRect(FRect);
1027 FDown := True;
1028 end;
1029
1030 procedure TfrFloatWindow.MouseMove(Shift: TShiftState; X, Y: Integer);
1031 var
1032 p: TPoint;
1033 begin
1034 if not FDown then Exit;
1035 GetCursorPos(p);
1036 DrawFrameRect(FRect);
1037 FRect := Rect(p.X, p.Y, p.X + Width, p.Y + Height);
1038 if ToolBar.FindDock(Owner as TWinControl,
1039 (Owner as TWinControl).ScreenToClient(Point(p.X, p.Y))) then
1040 Exit;
1041 DrawFrameRect(FRect);
1042 end;
1043
1044 procedure TfrFloatWindow.MouseUp(Button: TMouseButton; Shift: TShiftState;
1045 X, Y: Integer);
1046 begin
1047 DrawFrameRect(FRect);
1048 MoveWindowOrg(Handle,FRect.Left, FRect.Top);
1049 // MoveWindow(Handle, FRect.Left, FRect.Top, Width, Height, True);
1050 Show;
1051 FDown := False;
1052 end;
1053
1054 procedure TfrFloatWindow.FormShow(Sender: TObject);
1055 begin
1056 SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
1057 SWP_NOSIZE or SWP_NOACTIVATE);
1058 end;
1059
1060 procedure TfrFloatWindow.FormDestroy(Sender: TObject);
1061 begin
1062 if ToolBar <> nil then
1063 ToolBar.FWindow := nil;
1064 end;
1065
1066
1067 procedure Register;
1068 begin
1069 RegisterComponents('LR Tools', [TfrToolBar,TfrDock]);
1070 end;
1071
1072 {----------------------------------------------------------------------------}
1073 initialization
1074
1075 FloatingToolBars := TFpList.Create;
1076 RegRootKey := 'Software\FastReport';
1077
1078 finalization
1079
1080 DestroyToolbarList;
1081 FloatingToolBars.Free;
1082 end.
1083