/Source/FR_CHART.PAS
http://github.com/FastReports/FreeReport · Pascal · 537 lines · 466 code · 52 blank · 19 comment · 47 complexity · 07590ae78203c07f3e9e4374af0c049f MD5 · raw file
- {*****************************************}
- { }
- { FastReport v2.3 }
- { Chart Add-In Object }
- { }
- { Copyright (c) 1998-99 by Tzyganenko A. }
- { }
- {*****************************************}
-
- unit FR_Chart;
-
- interface
-
- {$I FR.inc}
-
- uses
- Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
- FR_Class, ExtCtrls, TeeProcs, TeEngine, Chart, Series, StdCtrls, FR_Ctrls,
- ComCtrls, Menus;
-
- type
- TChartOptions = packed record
- ChartType: Byte;
- Dim3D, IsSingle, ShowLegend, ShowAxis, ShowMarks, Colored: Boolean;
- MarksStyle: Byte;
- Top10Num: Integer;
- Reserved: Array[0..35] of Byte;
- end;
-
- TfrChartObject = class(TComponent) // fake component
- end;
-
- TfrChartView = class(TfrView)
- private
- CurStr: Integer;
- LastLegend: String;
- function ShowChart: Boolean;
- public
- Chart: TChartOptions;
- LegendObj, ValueObj, Top10Label: String;
- constructor Create; override;
- procedure Assign(From: TfrView); override;
- procedure Draw(Canvas: TCanvas); override;
- procedure Print(Stream: TStream); override;
- procedure LoadFromStream(Stream: TStream); override;
- procedure SaveToStream(Stream: TStream); override;
- procedure DefinePopupMenu(Popup: TPopupMenu); override;
- procedure OnHook(View: TfrView); override;
- end;
-
- TfrChartForm = class(TfrObjEditorForm)
- Image1: TImage;
- Page1: TPageControl;
- Tab1: TTabSheet;
- GroupBox1: TGroupBox;
- SB1: TfrSpeedButton;
- SB2: TfrSpeedButton;
- SB3: TfrSpeedButton;
- SB4: TfrSpeedButton;
- SB5: TfrSpeedButton;
- SB6: TfrSpeedButton;
- Tab2: TTabSheet;
- Button1: TButton;
- Button2: TButton;
- GroupBox2: TGroupBox;
- Label1: TLabel;
- E1: TEdit;
- Label2: TLabel;
- E2: TEdit;
- GroupBox3: TGroupBox;
- CB1: TCheckBox;
- CB2: TCheckBox;
- CB3: TCheckBox;
- CB4: TCheckBox;
- CB6: TCheckBox;
- CB5: TCheckBox;
- Tab3: TTabSheet;
- GroupBox4: TGroupBox;
- RB1: TRadioButton;
- RB2: TRadioButton;
- RB3: TRadioButton;
- RB4: TRadioButton;
- RB5: TRadioButton;
- GroupBox5: TGroupBox;
- Label3: TLabel;
- Label4: TLabel;
- E3: TEdit;
- E4: TEdit;
- Label5: TLabel;
- Chart1: TChart;
- procedure FormCreate(Sender: TObject);
- private
- { Private declarations }
- public
- { Public declarations }
- procedure ShowEditor(t: TfrView); override;
- end;
-
-
- implementation
-
- uses FR_Intrp, FR_Pars, FR_Utils, FR_Const;
-
- {$R *.DFM}
-
- type
- THackView = class(TfrView)
- end;
-
- TSeriesClass = class of TChartSeries;
-
- var
- frChartForm: TfrChartForm;
- SChart: TChart;
-
- const
- ChartTypes: Array[0..5] of TSeriesClass =
- (TLineSeries, TAreaSeries, TPointSeries,
- TBarSeries, THorizBarSeries, TPieSeries);
-
- function ExtractFieldName(const Fields: string; var Pos: Integer): string;
- var
- i: Integer;
- begin
- i := Pos;
- while (i <= Length(Fields)) and (Fields[i] <> ';') do Inc(i);
- Result := Copy(Fields, Pos, i - Pos);
- if (i <= Length(Fields)) and (Fields[i] = ';') then Inc(i);
- Pos := i;
- end;
-
- constructor TfrChartView.Create;
- begin
- inherited Create;
- with Chart do
- begin
- Dim3D := True;
- IsSingle := True;
- ShowLegend := True;
- ShowMarks := True;
- Colored := True;
- end;
- Typ := gtAddIn;
- BaseName := 'Chart';
- Flags := Flags or flWantHook;
- end;
-
- procedure TfrChartView.Assign(From: TfrView);
- begin
- inherited Assign(From);
- Chart := TfrChartView(From).Chart;
- LegendObj := TfrChartView(From).LegendObj;
- ValueObj := TfrChartView(From).ValueObj;
- Top10Label := TfrChartView(From).Top10Label;
- end;
-
- function TfrChartView.ShowChart: Boolean;
- var
- i, j, c1, c2: Integer;
- LegS, ValS, s: String;
- Ser: TChartSeries;
- EMF: TMetafile;
-
- function Str2Float(s: String): Double;
- begin
- s := Trim(s);
- while (Length(s) > 0) and not (s[1] in ['0'..'9']) do
- s := Copy(s, 2, 255); // trim all non-digit chars at the begin
- while (Length(s) > 0) and not (s[Length(s)] in ['0'..'9']) do
- s := Copy(s, 1, Length(s) - 1); // trim all non-digit chars at the end
- while Pos(ThousandSeparator, s) <> 0 do
- Delete(s, Pos(ThousandSeparator, s), 1);
- Result := 0;
- try
- Result := StrToFloat(s);
- except
- on exception do;
- end;
- end;
-
- procedure SortValues(var LegS, ValS: String);
- var
- i, j: Integer;
- sl: TStringList;
- s: String;
- d: Double;
- begin
- sl := TStringList.Create;
- sl.Sorted := True;
-
- i := 1; j := 1;
- while i <= Length(LegS) do
- sl.Add(SysUtils.Format('%12.3f', [Str2Float(ExtractFieldName(ValS, j))]) + '=' +
- ExtractFieldName(LegS, i));
-
- LegS := ''; ValS := '';
- for i := 1 to Chart.Top10Num do
- begin
- s := sl[sl.Count - i];
- ValS := ValS + Copy(s, 1, Pos('=', s) - 1) + ';';
- LegS := LegS + Copy(s, Pos('=', s) + 1, 255) + ';';
- end;
-
- i := sl.Count - Chart.Top10Num - 1; d := 0;
- while i >= 0 do
- begin
- s := sl[i];
- d := d + Str2Float(Copy(s, 1, Pos('=', s) - 1));
- Dec(i);
- end;
-
- LegS := LegS + Top10Label + ';';
- ValS := ValS + FloatToStr(d) + ';';
- sl.Free;
- end;
-
-
- begin
- Result := False;
- SChart.RemoveAllSeries;
- with Chart do
- begin
- SChart.Frame.Visible := False;
- SChart.LeftWall.Brush.Style := bsClear;
- SChart.BottomWall.Brush.Style := bsClear;
-
- SChart.View3D := Dim3D;
- SChart.Legend.Visible := ShowLegend;
- SChart.AxisVisible := ShowAxis;
- SChart.View3DWalls := ChartType <> 5;
- {$IFDEF Delphi4}
- SChart.BackWall.Brush.Style := bsClear;
- SChart.View3DOptions.Elevation := 315;
- SChart.View3DOptions.Rotation := 360;
- SChart.View3DOptions.Orthogonal := ChartType <> 5;
- {$ENDIF}
- end;
-
- if Memo.Count > 0 then
- LegS := Memo[0] else
- LegS := '';
- if Memo.Count > 1 then
- ValS := Memo[1] else
- ValS := '';
-
- if (LegS = '') or (ValS = '') then Exit;
- if LegS[Length(LegS)] <> ';' then
- LegS := LegS + ';';
- if ValS[Length(ValS)] <> ';' then
- ValS := ValS + ';';
-
- if Chart.IsSingle then
- begin
- Ser := ChartTypes[Chart.ChartType].Create(SChart);
- SChart.AddSeries(Ser);
- if Chart.Colored then
- Ser.ColorEachPoint := True;
- Ser.Marks.Visible := Chart.ShowMarks;
- Ser.Marks.Style := TSeriesMarksStyle(Chart.MarksStyle);
-
- c1 := 0;
- for i := 1 to Length(LegS) do
- if LegS[i] = ';' then Inc(c1);
- c2 := 0;
- for i := 1 to Length(ValS) do
- if ValS[i] = ';' then Inc(c2);
- if c1 <> c2 then Exit;
-
- if (Chart.Top10Num > 0) and (c1 > Chart.Top10Num) then
- SortValues(LegS, ValS);
- i := 1; j := 1;
- while i <= Length(LegS) do
- begin
- s := ExtractFieldName(ValS, j);
- Ser.Add(Str2Float(s), ExtractFieldName(LegS, i), clTeeColor);
- end;
- end
- else
- begin
- c1 := 0;
- for i := 1 to Length(LegS) do
- if LegS[i] = ';' then Inc(c1);
- if c1 <> Memo.Count - 1 then Exit;
-
- i := 1;
- c1 := 1;
- while i <= Length(LegS) do
- begin
- Ser := ChartTypes[Chart.ChartType].Create(SChart);
- SChart.AddSeries(Ser);
- Ser.Title := ExtractFieldName(LegS, i);
- Ser.Marks.Visible := Chart.ShowMarks;
- Ser.Marks.Style := TSeriesMarksStyle(Chart.MarksStyle);
- ValS := Memo[c1];
- if ValS[Length(ValS)] <> ';' then
- ValS := ValS + ';';
- j := 1;
- while j <= Length(ValS) do
- begin
- s := ExtractFieldName(ValS, j);
- Ser.Add(Str2Float(s), '', clTeeColor);
- end;
- Inc(c1);
- end;
- end;
-
- with Canvas do
- begin
- SChart.Color := FillColor;
- EMF := SChart.TeeCreateMetafile(False, Rect(0, 0, SaveDX, SaveDY));
- StretchDraw(DRect, EMF);
- EMF.Free;
- end;
- Result := True;
- end;
-
- procedure TfrChartView.Draw(Canvas: TCanvas);
- begin
- BeginDraw(Canvas);
- Memo1.Assign(Memo);
- CalcGaps;
- if not ShowChart then
- ShowBackground;
- ShowFrame;
- RestoreCoord;
- end;
-
- procedure TfrChartView.Print(Stream: TStream);
- begin
- BeginDraw(Canvas);
- Memo1.Assign(Memo);
- CurReport.InternalOnEnterRect(Memo1, Self);
- frInterpretator.DoScript(Script);
- if not Visible then Exit;
-
- Stream.Write(Typ, 1);
- frWriteString(Stream, ClassName);
- SaveToStream(Stream);
- end;
-
- procedure TfrChartView.LoadFromStream(Stream: TStream);
- var
- b: Byte;
- function ReadString(Stream: TStream): String;
- begin
- if frVersion >= 23 then
- {$IFDEF FREEREP2217READ}
- begin
- if (frVersion = 23) and FRE_COMPATIBLE_READ then
- Result := frReadString2217(Stream) // load in bad format
- else
- Result := frReadString(Stream); // load in current format
- end
- else
- {$ELSE}
- Result := frReadString(Stream) else
- {$ENDIF}
- Result := frReadString22(Stream);
- end;
- begin
- inherited LoadFromStream(Stream);
- with Stream do
- begin
- Read(b, 1);
- Read(Chart, SizeOf(Chart));
- LegendObj := ReadString(Stream);
- ValueObj := ReadString(Stream);
- Top10Label := ReadString(Stream);
- end;
- end;
-
- procedure TfrChartView.SaveToStream(Stream: TStream);
- var
- b: Byte;
- begin
- inherited SaveToStream(Stream);
- with Stream do
- begin
- b := 0; // internal chart version
- Write(b, 1);
- Write(Chart, SizeOf(Chart));
- frWriteString(Stream, LegendObj);
- frWriteString(Stream, ValueObj);
- frWriteString(Stream, Top10Label);
- end;
- end;
-
- procedure TfrChartView.DefinePopupMenu(Popup: TPopupMenu);
- begin
- // no specific items in popup menu
- end;
-
- procedure TfrChartView.OnHook(View: TfrView);
- var
- i: Integer;
- s: String;
- begin
- if Memo.Count < 2 then
- begin
- Memo.Clear;
- Memo.Add('');
- Memo.Add('');
- end;
- i := -1;
- if AnsiCompareText(View.Name, LegendObj) = 0 then
- begin
- i := 0;
- Inc(CurStr);
- end
- else if AnsiCompareText(View.Name, ValueObj) = 0 then
- i := CurStr;
- if Chart.IsSingle then
- CurStr := 1;
-
- if i >= 0 then
- begin
- if Memo.Count <= i then
- while Memo.Count <= i do
- Memo.Add('');
- if THackView(View).Memo1.Count > 0 then
- begin
- s := THackView(View).Memo1[0];
- if LastLegend <> s then
- Memo[i] := Memo[i] + s + ';';
- LastLegend := s;
- end;
- end;
- end;
-
-
- {------------------------------------------------------------------------}
- procedure TfrChartForm.ShowEditor(t: TfrView);
- procedure SetButton(b: Array of TfrSpeedButton; n: Integer);
- begin
- b[n].Down := True;
- end;
- function GetButton(b: Array of TfrSpeedButton): Integer;
- var
- i: Integer;
- begin
- Result := 0;
- for i := 0 to High(b) do
- if b[i].Down then
- Result := i;
- end;
- procedure SetRButton(b: Array of TRadioButton; n: Integer);
- begin
- b[n].Checked := True;
- end;
- function GetRButton(b: Array of TRadioButton): Integer;
- var
- i: Integer;
- begin
- Result := 0;
- for i := 0 to High(b) do
- if b[i].Checked then
- Result := i;
- end;
- begin
- Page1.ActivePage := Tab1;
- with TfrChartView(t), Chart do
- begin
- SetButton([SB1, SB2, SB3, SB4, SB5, SB6], ChartType);
- SetRButton([RB1, RB2, RB3, RB4, RB5], MarksStyle);
- CB1.Checked := Dim3D;
- CB2.Checked := IsSingle;
- CB3.Checked := ShowLegend;
- CB4.Checked := ShowAxis;
- CB5.Checked := ShowMarks;
- CB6.Checked := Colored;
- E1.Text := LegendObj;
- E2.Text := ValueObj;
- E3.Text := IntToStr(Top10Num);
- E4.Text := Top10Label;
- if ShowModal = mrOk then
- begin
- frDesigner.BeforeChange;
- ChartType := GetButton([SB1, SB2, SB3, SB4, SB5, SB6]);
- MarksStyle := GetRButton([RB1, RB2, RB3, RB4, RB5]);
- Dim3D := CB1.Checked;
- IsSingle := CB2.Checked;
- ShowLegend := CB3.Checked;
- ShowAxis := CB4.Checked;
- ShowMarks := CB5.Checked;
- Colored := CB6.Checked;
- LegendObj := E1.Text;
- ValueObj := E2.Text;
- Top10Num := StrToInt(E3.Text);
- Top10Label := E4.Text;
- end;
- end;
- end;
-
- procedure TfrChartForm.FormCreate(Sender: TObject);
- begin
- Caption := LoadStr(frRes + 590);
- Tab1.Caption := LoadStr(frRes + 591);
- Tab2.Caption := LoadStr(frRes + 592);
- Tab3.Caption := LoadStr(frRes + 604);
- GroupBox1.Caption := LoadStr(frRes + 593);
- GroupBox2.Caption := LoadStr(frRes + 594);
- GroupBox3.Caption := LoadStr(frRes + 595);
- GroupBox4.Caption := LoadStr(frRes + 605);
- GroupBox5.Caption := LoadStr(frRes + 611);
- CB1.Caption := LoadStr(frRes + 596);
- CB2.Caption := LoadStr(frRes + 597);
- CB3.Caption := LoadStr(frRes + 598);
- CB4.Caption := LoadStr(frRes + 599);
- CB5.Caption := LoadStr(frRes + 600);
- CB6.Caption := LoadStr(frRes + 601);
- RB1.Caption := LoadStr(frRes + 606);
- RB2.Caption := LoadStr(frRes + 607);
- RB3.Caption := LoadStr(frRes + 608);
- RB4.Caption := LoadStr(frRes + 609);
- RB5.Caption := LoadStr(frRes + 610);
- Label1.Caption := LoadStr(frRes + 602);
- Label2.Caption := LoadStr(frRes + 603);
- Label3.Caption := LoadStr(frRes + 612);
- Label4.Caption := LoadStr(frRes + 613);
- Label5.Caption := LoadStr(frRes + 614);
- Button1.Caption := LoadStr(SOk);
- Button2.Caption := LoadStr(SCancel);
- end;
-
- initialization
- frChartForm := TfrChartForm.Create(nil);
- SChart := frChartForm.Chart1;
- frRegisterObject(TfrChartView, frChartForm.Image1.Picture.Bitmap,
- LoadStr(SInsChart), frChartForm);
-
- finalization
- frChartForm.Free;
- frChartForm := nil;
-
- end.