Delphi/FastReport_FMX_2.8.12
Delphi/FastReport_FMX_2.8.12
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
master
FastReport_FMX_2.8.12/LibD28x64/FMX.frxDesgnCtrls.pas

1299 lines
31 KiB
ObjectPascal
Raw Permalink Normal View History

Init
2024-01-10 21:50:38 +01:00
{******************************************}
{ }
{ FastReport v4.0 }
{ Designer controls }
{ }
{ Copyright (c) 1998-2008 }
{ by Alexander Tzyganenko, }
{ Fast Reports Inc. }
{ }
{******************************************}
unit FMX.frxDesgnCtrls;
interface
{$I fmx.inc}
{$I frx.inc}
{$I fmx.inc}
uses
System.SysUtils, System.Classes, System.Types, System.UITypes, FMX.Objects, FMX.Types,
FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Layouts, FMX.frxClass, FMX.frxPictureCache,
System.Variants, FMX.TabControl, System.UIConsts
{$IFDEF DELPHI18}
,FMX.StdCtrls
{$ENDIF}
{$IFDEF DELPHI19}
, FMX.Graphics
{$ENDIF}
{$IFDEF DELPHI20}
, System.Math.Vectors
{$ENDIF}
{$IFDEF DELPHI28}
, FMX.BaseTypeAliases, FMX.FormTypeAliases
{$ENDIF};
type
TfrxRulerUnits = (ruCM, ruInches, ruPixels, ruChars);
{$I frxFMX_PlatformsAttribute.inc}
TfrxRuler = class(TPanel)
private
FOffset: Integer;
FScale: Double;
FStart: Integer;
FUnits: TfrxRulerUnits;
FPosition: Double;
FRulerSize: Integer;
FBitmap: TBitmap;
FNeedRedraw: Boolean;
FBackgroundColor: TAlphaColor;
procedure SetOffset(const Value: Integer);
procedure SetScale(const Value: Double);
procedure SetStart(const Value: Integer);
procedure SetUnits(const Value: TfrxRulerUnits);
procedure SetPosition(const Value: Double);
procedure SetRulerSize(const Value: Integer);
protected
procedure DoContentPaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF); virtual;
procedure DrawRuler;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ApplyStyle; override;
published
property Offset: Integer read FOffset write SetOffset;
property Scale: Double read FScale write SetScale;
property Start: Integer read FStart write SetStart;
property Units: TfrxRulerUnits read FUnits write SetUnits default ruPixels;
property RulePosition: Double read FPosition write SetPosition;
property RulerSize: Integer read FRulerSize write SetRulerSize;
end;
TfrxScrollBox = class(TScrollBox)
private
FContent: TContent;
FOnPositionChanged: TNotifyEvent;
protected
procedure ApplyStyle; override;
procedure DoContentPaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF); virtual;
procedure DialogKey(var Key: Word; Shift: TShiftState); override;
procedure KeyDown(var Key: Word; var KeyChar: WideChar; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; var KeyChar: WideChar; Shift: TShiftState); override;
{$IFDEF DELPHI18}
procedure HScrollChange; override;
procedure VScrollChange; override;
{$ELSE}
procedure HScrollChange(Sender: TObject); override;
procedure VScrollChange(Sender: TObject); override;
{$ENDIF}
{$IFDEF DELPHI18}
// public
// property HScrollBar;
// property VScrollBar;
{$ENDIF}
published
property OnPositionChanged: TNotifyEvent read FOnPositionChanged write FOnPositionChanged;
end;
TfrxTabControl = class(TTabControl)
protected
procedure ApplyStyle; override;
end;
TfrxCustomSelector = class(TPopup)
protected
FMouseOver: Boolean;
FX, FY: Single;
procedure DrawEdge(X, Y: Single); virtual; abstract;
procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
procedure DoMouseEnter; override;
procedure DoMouseLeave; override;
public
constructor Create(AOwner: TComponent); override;
procedure Popup(AControl: TControl); reintroduce; overload;
end;
TfrxColorSelector = class(TfrxCustomSelector)
private
FColor: TColor;
FOnColorChanged: TNotifyEvent;
FBtnCaption: String;
protected
procedure DrawEdge(X, Y: Single); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Single); override;
public
constructor Create(AOwner: TComponent); override;
procedure DoPaint; override;
property Color: TColor read FColor write FColor;
property OnColorChanged: TNotifyEvent read FOnColorChanged write FOnColorChanged;
property BtnCaption: String read FBtnCaption write FBtnCaption;
end;
TfrxLineSelector = class(TfrxCustomSelector)
private
FStyle: Byte;
FOnStyleChanged: TNotifyEvent;
protected
procedure DrawEdge(X, Y: Single); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Single); override;
public
constructor Create(AOwner: TComponent); override;
procedure DoPaint; override;
property Style: Byte read FStyle;
property OnStyleChanged: TNotifyEvent read FOnStyleChanged write FOnStyleChanged;
end;
TfrxUndoBuffer = class(TObject)
private
FPictureCache: TfrxPictureCache;
FRedo: TList;
FUndo: TList;
function GetRedoCount: Integer;
function GetUndoCount: Integer;
procedure SetPictureFlag(ReportComponent: TfrxComponent; Flag: Boolean);
procedure SetPictures(ReportComponent: TfrxComponent);
public
constructor Create;
destructor Destroy; override;
procedure AddUndo(ReportComponent: TfrxComponent);
procedure AddRedo(ReportComponent: TfrxComponent);
procedure GetUndo(ReportComponent: TfrxComponent);
procedure GetRedo(ReportComponent: TfrxComponent);
procedure ClearUndo;
procedure ClearRedo;
property UndoCount: Integer read GetUndoCount;
property RedoCount: Integer read GetRedoCount;
property PictureCache: TfrxPictureCache read FPictureCache write FPictureCache;
end;
TfrxClipboard = class(TObject)
private
FDesigner: TfrxCustomDesigner;
FPictureCache: TfrxPictureCache;
function GetPasteAvailable: Boolean;
public
constructor Create(ADesigner: TfrxCustomDesigner);
procedure Copy;
procedure Paste;
property PasteAvailable: Boolean read GetPasteAvailable;
property PictureCache: TfrxPictureCache read FPictureCache write FPictureCache;
end;
implementation
uses
System.Math, FMX.frxDMPClass, FMX.frxDsgnIntf, FMX.frxCtrls, FMX.frxXMLSerializer, FMX.Platform,
FMX.frxUtils, FMX.frxXML, FMX.frxFMX;
const
Colors: array[0..47] of TAlphaColor =
(claNull, claWhite, claBlack, claMaroon, claGreen, claOlive, claNavy, claPurple,
claGray, claSilver, claTeal, claRed, claLime, claYellow, claBlue, claFuchsia,
$FFCCCCCC, $FFE4E4E4, claAqua, $FF00CCFF, $FF00CC98, $FF98FFFF, $FFFFCC00, $FFFF98CC,
$FFD8D8D8, $FFF0F0F0, $FFFFFFDC, $FFCAE4FF, $FFCCFFCC, $FFCCFFFF, $FFFFF4CC, $FFCC98FF,
claGray, $FF46DAFF, $FF9BEBFF, $FF00A47B, $FFFDBD97, $FFFED3BA, $FF6ACFFF, $FFFFF4CC,
claGray, claGray, claGray, claGray, claGray, claGray, claGray, claGray);
{ TfrxRuler }
procedure TfrxRuler.ApplyStyle;
var
StyleObject: TFmxObject;
begin
inherited;
StyleObject := GetStyleObject;
try
if StyleObject is TRectangle then
FBackgroundColor := TRectangle(StyleObject).Fill.Color
finally
StyleObject.Free;
end;
end;
constructor TfrxRuler.Create(AOwner: TComponent);
begin
inherited;
FScale := 1;
OnPaint := DoContentPaint;
StyleLookup := 'backgroundstyle';
FBackgroundColor := $FFF5F5F5;
FBitmap := TBitmap.Create(1, 1);
FNeedRedraw := True;
end;
destructor TfrxRuler.Destroy;
begin
FBitmap.Free;
inherited;
end;
procedure TfrxRuler.DoContentPaint(Sender: TObject; Canvas: TCanvas;
const ARect: TRectF);
var
SaveState: TCanvasSaveState;
procedure Line(x, y, dx, dy: Integer);
begin
Canvas.DrawLine(PointF(x + 0.5, y + 0.5), PointF(x + dx + 0.5, y + dy + 0.5), 1);
end;
procedure DrawLines;
var
i, dx: Single;
ofs: Integer;
begin
with Canvas do
begin
Stroke.Color := claBlack;
Stroke.Kind := TBrushKind.bkSolid;
Fill.Kind := TBrushKind.bkNone;
if FUnits = ruCM then
dx := fr01cm * FScale
else if FUnits = ruInches then
dx := fr01in * FScale
else if FUnits = ruChars then
begin
if Align = TAlignLayout.alLeft then
dx := fr1CharY * FScale / 10 else
dx := fr1CharX * FScale / 10
end
else
dx := FScale;
ofs := FOffset - FStart;
if FUnits = ruChars then
begin
if Align = TAlignLayout.alLeft then
Inc(ofs, Round(fr1CharY * FScale / 2)) else
Inc(ofs, Round(fr1CharX * FScale / 2))
end;
i := FPosition * dx;
if FUnits <> ruPixels then
i := i * 10;
if ofs + i >= FOffset then
if Align = TAlignLayout.alLeft then
Line(3, ofs + Round(i), 13, 0) else
Line(ofs + Round(i), 3, 0, 13);
end;
end;
begin
if FNeedRedraw then
begin
FNeedRedraw := False;
DrawRuler;
end;
SaveState := Canvas.SaveState;
try
Canvas.IntersectClipRect(ARect);
Canvas.DrawBitmap(FBitmap, RectF(0, 0, FBitmap.Width, FBitmap.Height), ARect, 1);
DrawLines;
finally
Canvas.RestoreState(SaveState);
end;
end;
procedure TfrxRuler.DrawRuler;
var
sz: Single;
SaveStateA, SaveStateB: TCanvasSaveState;
RMatrix, OldM: TMatrix;
procedure Line(x, y, dx, dy: Integer);
begin
FBitmap.Canvas.DrawLine(PointF(x + 0.5, y + 0.5), PointF(x + dx + 0.5, y + dy + 0.5), 1);
end;
procedure DrawLines;
var
i, dx, maxi, maxw, tx, ty: Single;
i1, h, w, w5, w10, ofs: Integer;
s: String;
begin
with FBitmap.Canvas do
begin
Stroke.Color := claBlack;
Stroke.Kind := TBrushKind.bkSolid;
Fill.Kind := TBrushKind.bkNone;
w5 := 5;
w10 := 10;
if FUnits = ruCM then
dx := fr01cm * FScale
else if FUnits = ruInches then
dx := fr01in * FScale
else if FUnits = ruChars then
begin
if Align = TAlignLayout.alLeft then
dx := fr1CharY * FScale / 10 else
dx := fr1CharX * FScale / 10
end
else
begin
dx := FScale;
w5 := 50;
w10 := 100;
end;
if FRulerSize = 0 then
begin
if Align = TAlignLayout.alLeft then
maxi := Height + FStart else
maxi := Self.Width + FStart;
end
else
maxi := FRulerSize;
if FUnits = ruPixels then
s := IntToStr(FStart + Round(maxi / dx)) else
s := IntToStr((FStart + Round(maxi / dx)) div 10);
maxw := TextWidth(s);
ofs := FOffset - FStart;
if FUnits = ruChars then
begin
if Align = TAlignLayout.alLeft then
Inc(ofs, Round(fr1CharY * FScale / 2)) else
Inc(ofs, Round(fr1CharX * FScale / 2))
end;
i := 0;
i1 := 0;
while i < maxi do
begin
h := 0;
if i1 = 0 then
h := 0
else if i1 mod w10 = 0 then
h := 6
else if i1 mod w5 = 0 then
h := 4
else if FUnits <> ruPixels then
h := 2;
if (h = 2) and (dx * w10 < 41) then
h := 0;
if (h = 4) and (dx * w10 < 21) then
h := 0;
w := 0;
if h = 6 then
begin
if maxw > dx * w10 * 1.5 then
w := w10 * 4
else if maxw > dx * w10 * 0.7 then
w := w10 * 2
else
w := w10;
end;
if FUnits = ruPixels then
s := IntToStr(i1) else
s := IntToStr(i1 div 10);
Fill.Color := claBlack;
Fill.Kind := TBrushKind.bkSolid;
if (w <> 0) and (i1 mod w = 0) and (ofs + i >= FOffset) then
begin
if Align = TAlignLayout.alLeft then
begin
tx := -(ofs + i - TextWidth(s) / 2 + 6);
ty := Self.Width - FBitmap.Canvas.TextHeight(s) - 8;
SaveStateB := SaveState;
SetMatrix(RMatrix);
end
else
begin
tx := ofs + Round(i) - TextWidth(s) / 2 + 1;
ty := 5;
end;
FillText(RectF(tx, ty, tx + 100, ty + 100), s, False, 1, [], TTextAlign.taLeading, TTextAlign.taLeading);
if Align = TAlignLayout.alLeft then
RestoreState(SaveStateB);
end
else if (h <> 0) and (ofs + i >= FOffset) then
if Align = TAlignLayout.alLeft then
Line(3 + (13 - h) div 2, ofs + Round(i), h, 0) else
Line(ofs + Round(i), 3 + (13 - h) div 2, 0, h);
i := i + dx;
Inc(i1);
end;
end;
end;
begin
FBitmap.SetSize(Round(Self.Width), Round(Self.Height));
FBitmap.Canvas.BeginScene();
SaveStateA := FBitmap.Canvas.SaveState;
try
with FBitmap.Canvas do
begin
Fill.Kind := TBrushKind.bkSolid;
Fill.Color := FBackgroundColor;
FillRect(RectF(0, 0, FBitmap.Width, FBitmap.Height), 1, 1, AllCorners, 1);
Fill.Color := claWhite;
{$IFDEF LINUX}
Font.Family := 'Liberation Sans';
{$ELSE}
Font.Family := 'Arial';
{$ENDIF}
Font.Size := 8;
if Align = TAlignLayout.alLeft then
begin
if FRulerSize = 0 then
sz := Self.Height
else
sz := FRulerSize + FOffset;
FillRect(RectF(3, FOffset, Self.Width - 5, sz), 1, 1, AllCorners, 1);
RMatrix := CreateRotationMatrix(-DegToRad(90));
//RMatrix.m31 := Self.GetAbsoluteRect.Left;
//RMatrix.m32 := Self.GetAbsoluteRect.Top;
RMatrix := MatrixMultiply(RMatrix, Matrix);
OldM := Matrix;
end
else
begin
if FRulerSize = 0 then
sz := Self.Width
else
sz := FRulerSize + FOffset;
FillRect(RectF(FOffset, 3, sz, Self.Height - 5), 1, 1, AllCorners, 1);
end;
end;
DrawLines;
finally
FBitmap.Canvas.RestoreState(SaveStateA);
FBitmap.Canvas.EndScene;
end;
end;
procedure TfrxRuler.SetOffset(const Value: Integer);
begin
FOffset := Value;
FNeedRedraw := True;
Repaint;
end;
procedure TfrxRuler.SetPosition(const Value: Double);
begin
FPosition := Value;
Repaint;
end;
procedure TfrxRuler.SetScale(const Value: Double);
begin
FScale := Value;
FNeedRedraw := True;
Repaint;
end;
procedure TfrxRuler.SetStart(const Value: Integer);
begin
FStart := Value;
FNeedRedraw := True;
Repaint;
end;
procedure TfrxRuler.SetUnits(const Value: TfrxRulerUnits);
begin
FUnits := Value;
FNeedRedraw := True;
Repaint;
end;
procedure TfrxRuler.SetRulerSize(const Value: Integer);
begin
FRulerSize := Value;
FNeedRedraw := True;
Repaint;
end;
{ TfrxScrollBox }
procedure TfrxScrollBox.ApplyStyle;
var
B: TFmxObject;
begin
inherited;
B := FindStyleResource('content');
if (B <> nil) and (B is TControl) then
begin
FContent := TContent(B);
FContent.OnPaint := DoContentPaint;
end;
end;
procedure TfrxScrollBox.DialogKey(var Key: Word; Shift: TShiftState);
begin
inherited;
end;
procedure TfrxScrollBox.DoContentPaint(Sender: TObject; Canvas: TCanvas;
const ARect: TRectF);
begin
Canvas.Fill.Kind := TBrushKind.bkSolid;
Canvas.Fill.Color := $FFE0E0E0;
Canvas.FillRect(ARect, 1, 1, AllCorners, 1, TCornerType.ctBevel);
end;
procedure TfrxScrollBox.KeyDown(var Key: Word; var KeyChar: WideChar; Shift: TShiftState);
//var
// i: Integer;
begin
inherited;
{for i := 0 to ControlCount - 1 do
if Controls[i] is TWinControl then
THackControl(Controls[i]).KeyDown(Key, Shift);}
end;
//procedure TfrxScrollBox.KeyPress(var Key: Char);
//var
// i: Integer;
//begin
// inherited;
// for i := 0 to ControlCount - 1 do
// if Controls[i] is TWinControl then
// THackControl(Controls[i]).KeyPress(Key);
//end;
procedure TfrxScrollBox.KeyUp(var Key: Word; var KeyChar: WideChar; Shift: TShiftState);
//var
// i: Integer;
begin
inherited;
{for i := 0 to ControlCount - 1 do
if Controls[i] is TWinControl then
THackControl(Controls[i]).KeyUp(Key, Shift);}
end;
{$IFDEF DELPHI18}
procedure TfrxScrollBox.HScrollChange;
{$ELSE}
procedure TfrxScrollBox.HScrollChange(Sender: TObject);
{$ENDIF}
begin
inherited;
if Assigned(FOnPositionChanged) then
FOnPositionChanged(Self);
end;
{$IFDEF DELPHI18}
procedure TfrxScrollBox.VScrollChange;
{$ELSE}
procedure TfrxScrollBox.VScrollChange(Sender: TObject);
{$ENDIF}
begin
inherited;
if Assigned(FOnPositionChanged) then
FOnPositionChanged(Self);
end;
{ TfrxCustomSelector }
constructor TfrxCustomSelector.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
StyleLookup := 'panelstyle';
end;
procedure TfrxCustomSelector.Popup(AControl: TControl);
begin
Tag := AControl.Tag;
PlacementTarget := AControl;
Popup;
end;
procedure TfrxCustomSelector.DoMouseEnter;
begin
FMouseOver := True;
Repaint;
end;
procedure TfrxCustomSelector.DoMouseLeave;
begin
FMouseOver := False;
Repaint;
end;
procedure TfrxCustomSelector.MouseMove(Shift: TShiftState; X, Y: Single);
begin
inherited;
FX := X;
FY := Y;
Repaint;
end;
{ TfrxColorSelector }
constructor TfrxColorSelector.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 155;
Height := 143;
FBtnCaption := 'Other...';
end;
procedure TfrxColorSelector.DrawEdge(X, Y: Single);
var
r: TRectF;
begin
X := Trunc((X - 5) / 18);
if X >= 8 then
X := 7;
Y := Trunc((Y - 5) / 18);
if Y < 6 then
r := RectF(X * 18 + 5.5, Y * 18 + 5.5, X * 18 + 23.5, Y * 18 + 23.5) else
r := RectF(5.5, 113.5, Width - 5.5, Height - 5.5);
with Canvas do
begin
Stroke.Kind := TBrushKind.bkSolid;
Stroke.Color := $FFC56A31;
DrawRect(r, 0, 0, AllCorners, 1);
InflateRect(r, -1, -1);
Stroke.Color := $FFE8E6E2;
DrawRect(r, 0, 0, AllCorners, 1);
InflateRect(r, -1, -1);
DrawRect(r, 0, 0, AllCorners, 1);
end;
end;
procedure TfrxColorSelector.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Single);
//var
//cd: TColorDialog;
procedure AddCustomColor;
var
i: Integer;
Found: Boolean;
Empty: Integer;
begin
Found := False;
Empty := 0;
for i := 0 to 47 do
begin
if Colors[i] = Cardinal(FColor) then
Found := True;
if (i > 37) and (Colors[i] = claGray) and (Empty = 0) then
Empty := i;
end;
if Found then exit;
if Empty = 0 then
begin
for i := 40 to 46 do
Colors[i] := Colors[i + 1];
Empty := 47;
end;
Colors[Empty] := FColor
end;
begin
X := Trunc((X - 5) / 18);
if X >= 8 then
X := 7;
Y := Trunc((Y - 5) / 18);
if Y < 6 then
FColor := Colors[Round(X + Y * 8)]
else
begin
//TForm(Parent).AutoSize := False;
//Parent.Height := 0;
//cd := TColorDialog.Create(Self);
//cd.Options := [cdFullOpen];
//cd.Color := FColor;
//if cd.Execute then
// FColor := cd.Color else
// Exit;
// todo color selector form
AddCustomColor;
end;
ClosePopup;
if Assigned(FOnColorChanged) then
FOnColorChanged(Self);
end;
procedure TfrxColorSelector.DoPaint;
var
i, j: Integer;
s: String;
r: TRectF;
begin
inherited;
with Canvas do
begin
Fill.Kind := TBrushKind.bkSolid;
Stroke.Kind := TBrushKind.bkSolid;
for j := 0 to 5 do
for i := 0 to 7 do
begin
if (i = 0) and (j = 0) then
Fill.Color := claWhite else
Fill.Color := Colors[i + j * 8];
Stroke.Color := claGray;
r := RectF(i * 18 + 8.5, j * 18 + 8.5, i * 18 + 20.5, j * 18 + 20.5);
FillRect(r, 0, 0, AllCorners, 1);
DrawRect(r, 0, 0, AllCorners, 1);
if (i = 0) and (j = 0) then
begin
DrawLine(PointF(i * 18 + 10.5, j * 18 + 10.5), PointF(i * 18 + 18.5, j * 18 + 18.5), 1);
DrawLine(PointF(i * 18 + 18.5, j * 18 + 10.5), PointF(i * 18 + 10.5, j * 18 + 18.5), 1);
end;
end;
Stroke.Color := claGray;
Fill.Color := claGray;
s := FBtnCaption;
{$IFDEF LINUX}
DrawRect(RectF(8.5, 116.5, Width - 20, Height - 20), 0, 0, AllCorners, 1);
FillText(RectF(8.5, 116.5, Width - 20, Height - 20), s, False, 1, [], TTextAlign.taCenter, TTextAlign.taCenter)
{$ELSE}
DrawRect(RectF(8.5, 116.5, Width - 8.5, Height - 8.5), 0, 0, AllCorners, 1);
FillText(RectF(10, 116, Width - 10, Height - 8), s, False, 1, [], TTextAlign.taCenter, TTextAlign.taCenter)
{$ENDIF}
end;
if FMouseOver then
DrawEdge(FX, FY);
end;
{ TfrxLineSelector }
constructor TfrxLineSelector.Create(AOwner: TComponent);
begin
inherited;
Width := 98;
Height := 106;
end;
procedure TfrxLineSelector.DrawEdge(X, Y: Single);
var
r: TRectF;
begin
Y := Trunc((Y - 5) / 16);
if Y > 5 then
Y := 5;
r := RectF(5.5, Y * 16 + 5.5, Width - 6.5, Y * 16 + 19.5);
with Canvas do
begin
Stroke.Kind := TBrushKind.bkSolid;
Stroke.Color := claGray;
{$IFDEF Delphi25}
Stroke.Thickness := 1;
{$ELSE}
StrokeThickness := 1;
{$ENDIF}
DrawRect(r, 0, 0, AllCorners, 1);
end;
end;
procedure TfrxLineSelector.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Single);
begin
Y := Trunc((Y - 5) / 16);
if Y > 5 then
Y := 5;
FStyle := Round(Y);
ClosePopup;
if Assigned(FOnStyleChanged) then
FOnStyleChanged(Self);
end;
procedure TfrxLineSelector.DoPaint;
var
i: Integer;
procedure DrawLine(Y, Style: Integer);
begin
if Style = 5 then
begin
Style := 0;
DrawLine(Y - 2, Style);
Inc(Y, 2);
end;
with Canvas do
begin
Stroke.Color := claBlack;
{$IFDEF Delphi25}
Stroke.Thickness := 2;
Stroke.Dash := TStrokeDash(Style);
{$ELSE}
StrokeDash := TStrokeDash(Style);
StrokeThickness := 2;
{$ENDIF}
DrawLine(PointF(7, Y), PointF(Self.Width - 8, Y), 1);
end;
end;
begin
inherited;
for i := 0 to 5 do
DrawLine(12 + i * 16, i);
if FMouseOver then
DrawEdge(FX, FY);
end;
{ TfrxUndoBuffer }
constructor TfrxUndoBuffer.Create;
begin
FRedo := TList.Create;
FUndo := TList.Create;
end;
destructor TfrxUndoBuffer.Destroy;
begin
ClearUndo;
ClearRedo;
FUndo.Free;
FRedo.Free;
inherited;
end;
procedure TfrxUndoBuffer.AddUndo(ReportComponent: TfrxComponent);
var
m: TMemoryStream;
begin
m := TMemoryStream.Create;
FUndo.Add(m);
SetPictureFlag(ReportComponent, False);
try
ReportComponent.SaveToStream(m);
finally
SetPictureFlag(ReportComponent, True);
end;
end;
procedure TfrxUndoBuffer.AddRedo(ReportComponent: TfrxComponent);
var
m: TMemoryStream;
begin
m := TMemoryStream.Create;
FRedo.Add(m);
SetPictureFlag(ReportComponent, False);
try
ReportComponent.SaveToStream(m);
finally
SetPictureFlag(ReportComponent, True);
end;
end;
procedure TfrxUndoBuffer.GetUndo(ReportComponent: TfrxComponent);
var
m: TMemoryStream;
IsReport: Boolean;
begin
IsReport := False;
if ReportComponent is TfrxReport then
isReport := True;
m := FUndo[FUndo.Count - 2];
m.Position := 0;
if IsReport then
TfrxReport(ReportComponent).Reloading := True;
try
ReportComponent.LoadFromStream(m);
finally
if IsReport then
TfrxReport(ReportComponent).Reloading := False;
end;
SetPictures(ReportComponent);
m := FUndo[FUndo.Count - 1];
m.Free;
FUndo.Delete(FUndo.Count - 1);
end;
procedure TfrxUndoBuffer.GetRedo(ReportComponent: TfrxComponent);
var
m: TMemoryStream;
IsReport: Boolean;
begin
IsReport := False;
if ReportComponent is TfrxReport then
isReport := True;
m := FRedo[FRedo.Count - 1];
m.Position := 0;
if IsReport then
TfrxReport(ReportComponent).Reloading := True;
try
ReportComponent.LoadFromStream(m);
finally
if IsReport then
TfrxReport(ReportComponent).Reloading := False;
end;
SetPictures(ReportComponent);
m.Free;
FRedo.Delete(FRedo.Count - 1);
end;
procedure TfrxUndoBuffer.ClearUndo;
begin
while FUndo.Count > 0 do
begin
TMemoryStream(FUndo[0]).Free;
FUndo.Delete(0);
end;
end;
procedure TfrxUndoBuffer.ClearRedo;
begin
while FRedo.Count > 0 do
begin
TMemoryStream(FRedo[0]).Free;
FRedo.Delete(0);
end;
end;
function TfrxUndoBuffer.GetRedoCount: Integer;
begin
Result := FRedo.Count;
end;
function TfrxUndoBuffer.GetUndoCount: Integer;
begin
Result := FUndo.Count;
end;
procedure TfrxUndoBuffer.SetPictureFlag(ReportComponent: TfrxComponent; Flag: Boolean);
var
i: Integer;
l: TList;
c: TfrxComponent;
begin
l := ReportComponent.AllObjects;
for i := 0 to l.Count - 1 do
begin
c := l[i];
if c is TfrxPictureView then
begin
TfrxPictureView(c).IsPictureStored := Flag;
TfrxPictureView(c).IsImageIndexStored := not Flag;
end;
end;
end;
procedure TfrxUndoBuffer.SetPictures(ReportComponent: TfrxComponent);
var
i: Integer;
l: TList;
c: TfrxComponent;
begin
l := ReportComponent.AllObjects;
for i := 0 to l.Count - 1 do
begin
c := l[i];
if c is TfrxPictureView then
FPictureCache.GetPicture(TfrxPictureView(c));
end;
end;
{ TfrxClipboard }
constructor TfrxClipboard.Create(ADesigner: TfrxCustomDesigner);
begin
FDesigner := ADesigner;
end;
procedure TfrxClipboard.Copy;
var
c, c1: TfrxComponent;
i, j: Integer;
text: String;
minX, minY: Extended;
List: TList;
Flag: Boolean;
procedure Write(c: TfrxComponent);
var
c1: TfrxComponent;
Writer: TfrxXMLSerializer;
begin
c1 := TfrxComponent(c.NewInstance);
c1.Create(FDesigner.Page);
if c is TfrxPictureView then
begin
TfrxPictureView(c).IsPictureStored := False;
TfrxPictureView(c).IsImageIndexStored := True;
end;
try
c1.Assign(c);
finally
if c is TfrxPictureView then
begin
TfrxPictureView(c).IsPictureStored := True;
TfrxPictureView(c).IsImageIndexStored := False;
TfrxPictureView(c1).IsImageIndexStored := True;
end;
end;
c1.Left := c1.Left - minX;
c1.Top := c.AbsTop - minY;
Writer := TfrxXMLSerializer.Create(nil);
Writer.Owner := c1.Report;
text := text + '<' + c1.ClassName + ' Name="' + c.Name + '"' + Writer.ObjToXML(c1) + '/>';
Writer.Free;
c1.Free;
end;
begin
text := '#FR3 clipboard#' + #10#13;
minX := 100000;
minY := 100000;
for i := 0 to FDesigner.SelectedObjects.Count - 1 do
begin
c := FDesigner.SelectedObjects[i];
if c.AbsLeft < minX then
minX := c.AbsLeft;
if c.AbsTop < minY then
minY := c.AbsTop;
end;
List := FDesigner.Page.AllObjects;
for i := 0 to List.Count - 1 do
begin
c := List[i];
if FDesigner.SelectedObjects.IndexOf(c) <> -1 then
begin
Write(c);
if c is TfrxBand then
begin
Flag := False;
for j := 0 to c.Objects.Count - 1 do
begin
c1 := c.Objects[j];
if FDesigner.SelectedObjects.IndexOf(c1) <> -1 then
Flag := True;
end;
if not Flag then
for j := 0 to c.Objects.Count - 1 do
Write(c.Objects[j]);
end;
end;
end;
SetClipboard(text);
end;
function TfrxClipboard.GetPasteAvailable: Boolean;
var
cb: Variant;
begin
Result := False;
try
cb := GetClipboard;
if cb <> null then
Result := (Pos('#FR3 clipboard#', cb) = 1);
except
Result := False;
end;
end;
procedure TfrxClipboard.Paste;
var
c: TfrxComponent;
sl: TStrings;
s: TStream;
List: TList;
NewCompName: string;
NewComp: TfrxComponent;
function ReadComponent_(AReader: TfrxXMLSerializer; Root: TfrxComponent): TfrxComponent;
var
rd: TfrxXMLReader;
RootItem: TfrxXMLItem;
begin
rd := TfrxXMLReader.Create(AReader.Stream);
RootItem := TfrxXMLItem.Create;
try
rd.ReadRootItem(RootItem, False);
Result := AReader.ReadComponentStr(Root, RootItem.Name + ' ' + RootItem.Text);
NewCompName := RootItem.Prop['Name'];
finally
rd.Free;
RootItem.Free;
end;
end;
function ReadComponent: TfrxComponent;
var
Reader: TfrxXMLSerializer;
begin
Reader := TfrxXMLSerializer.Create(s);
Result := ReadComponent_(Reader, FDesigner.Report);
Reader.Free;
end;
function FindBand(Band: TfrxComponent): Boolean;
var
i: Integer;
begin
Result := False;
for i := 0 to FDesigner.Page.Objects.Count - 1 do
if (FDesigner.Page.Objects[i] <> Band) and
(TObject(FDesigner.Page.Objects[i]) is Band.ClassType) then
Result := True;
end;
function CanInsert(c: TfrxComponent): Boolean;
begin
Result := True;
if (c is TfrxDialogControl) and (FDesigner.Page is TfrxReportPage) then
Result := False;
if not (c is TfrxDialogComponent) and not (c is TfrxDialogControl) and
(FDesigner.Page is TfrxDialogPage) then
Result := False;
if ((c is TfrxDMPMemoView) or (c is TfrxDMPLineView) or (c is TfrxDMPCommand)) and
not (FDesigner.Page is TfrxDMPPage) then
Result := False;
if not ((c is TfrxBand) or (c is TfrxDMPMemoView) or (c is TfrxDMPLineView) or
(c is TfrxDMPCommand)) and (FDesigner.Page is TfrxDMPPage) then
Result := False;
if not ((c is TfrxCustomLineView) or (c is TfrxCustomMemoView) or
(c is TfrxShapeView) or (c is TfrxDialogComponent)) and
(FDesigner.Page is TfrxDataPage) then
Result := False;
end;
procedure FindParent(c: TfrxComponent);
var
i: Integer;
Found: Boolean;
c1: TfrxComponent;
begin
Found := False;
if not (c is TfrxBand) then
for i := List.Count - 1 downto 0 do
begin
c1 := List[i];
if c1 is TfrxBand then
if (c.Top >= c1.Top) and (c.Top < c1.Top + c1.Height) then
begin
c.Parent := c1;
c.Top := c.Top - c1.Top;
Found := True;
break;
end;
end;
if not Found then
c.Parent := FDesigner.Page;
end;
begin
FDesigner.SelectedObjects.Clear;
sl := TStringList.Create;
sl.Text := GetClipboard;
sl.Delete(0);
s := TMemoryStream.Create;
sl.SaveToStream(s, TEncoding.UTF8);
sl.Free;
s.Position := 0;
List := TList.Create;
while s.Position < s.Size do
begin
c := ReadComponent;
if c = nil then break;
if (((c is TfrxReportTitle) or (c is TfrxReportSummary) or
(c is TfrxPageHeader) or (c is TfrxPageFooter) or
(c is TfrxColumnHeader) or (c is TfrxColumnFooter)) and FindBand(c)) or
not CanInsert(c) then
c.Free
else
begin
if c is TfrxPictureView then
FPictureCache.GetPicture(TfrxPictureView(c));
List.Add(c);
FindParent(c);
if FDesigner.IsPreviewDesigner then
NewComp := FDesigner.Report.FindObject(NewCompName) as TfrxComponent
else
NewComp := FDesigner.Report.FindComponent(NewCompName) as TfrxComponent;
if ((NewComp <> nil) and (NewComp <> c)) or (NewCompName = '') then
c.CreateUniqueName
else
c.Name := NewCompName;
c.GroupIndex := 0;
FDesigner.Objects.Add(c);
if c.Parent = FDesigner.Page then
FDesigner.SelectedObjects.Add(c);
c.OnPaste;
end;
end;
if FDesigner.SelectedObjects.Count = 0 then
FDesigner.SelectedObjects.Add(FDesigner.Page);
List.Free;
s.Free;
end;
{ TfrxTabControl }
procedure TfrxTabControl.ApplyStyle;
var
B: TFmxObject;
begin
inherited;
B := FindStyleResource('rectangle');
if (B <> nil) and (B is TRectangle) then
TRectangle(B).Sides := [];
end;
initialization
StartClassGroup(TFmxObject);
ActivateClassGroup(TFmxObject);
GroupDescendentsWith(TfrxRuler, TFmxObject);
GroupDescendentsWith(TfrxScrollBox, TFmxObject);
RegisterFmxClasses([TfrxRuler, TfrxScrollBox]);
end.
Reference in New Issue Copy Permalink