Delphi/FastReport_2022_VCL
Delphi/FastReport_2022_VCL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
master
FastReport_2022_VCL/LibD28x64/ConverterRB2FR.pas

1187 lines
33 KiB
ObjectPascal
Raw Permalink Normal View History

Inicijalizacija
2024-01-01 16:13:08 +01:00
{******************************************}
{ }
{ FastReport VCL }
{ RB -> FR importer }
{ }
{ Copyright (c) 1998-2021 }
{ }
{******************************************}
unit ConverterRB2FR ;
interface
{$I frx.inc}
implementation
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls, Printers, TypInfo, Jpeg, DB,
frxClass, frxVariables, frxPrinter, frxDCtrl, frxBarcode, frxBarcod,frxMap,
{$IFDEF DELPHI16}
VCLTee.TeeProcs, VCLTee.TeEngine, VCLTee.Chart, VCLTee.Series, VCLTee.TeCanvas
{$ELSE}
TeeProcs, TeEngine, Chart, Series, TeCanvas
{$ENDIF}
{$IFDEF DELPHI16}
{$IFDEF TeeChartPro}, VCLTEE.TeeEdit{$IFNDEF TeeChart4}, VCLTEE.TeeEditCha{$ENDIF} {$ENDIF}
{$ELSE}
{$IFDEF TeeChartPro}, TeeEdit{$IFNDEF TeeChart4}, TeeEditCha{$ENDIF} {$ENDIF}
{$ENDIF}
, frxChart, frxChBox, frxOLE, frxRich,
frxCross, frxDBSet, frxUnicodeUtils, frxUtils, fs_ipascal,
frxCustomDB, {frxBDEComponents,} frxADOComponents, frxIBXComponents,
frxBarcode2D,frxTableObject
{$IFDEF Delphi6}
, Variants
{$ENDIF};
type
TfrxFR2EventsNew = class(TObject)
private
function DoLoad(Sender: TfrxReport; Stream: TStream): Boolean;
procedure OnFindComponentClass(Reader: TReader; const ClassName: string;
var ComponentClass: TComponentClass);
end;
TppDuplex = (dpNone, dpHorizontal, dpVertical);
TppFrame = (bpLeft, bpRight, bpTop, bpBottom);
TShapeType = (stRectangle, stRoundRect, stEllipse, stSquare, stRoundSquare ,stCircle);
TRBVarType =(vtDate, vtDateTime, vtDocumentName, vtPrintDateTime, vtPageCount ,vtPageSet,vtPageSetDesc,vtPageNo, vtPageNoDesc, vtTime);
TppBarTypes = (bcUPC_A, bcUPC_E, bcEAN_13, bcEAN_8, bcInt2of5, bcCode128, bcCode39, bcPostnet, bcFIM, bcCodabar, bcMSI,bcIntelligentMail);
Tpp2DBarTypes = (bcPDF417, bcMaxicode, bcQRCode, bcDataMatrix, bcAztecCode);
TAssignProp = procedure ();
var
frxFR2EventsNew: TfrxFR2EventsNew;
const RBVarsCat = ' RBVariables';
function LoadFromRB(AReport: TfrxReport; AStream: TStream; MyEvent: TfrxFR2EventsNew): Boolean;
Var
Reader: TReader;
SaveSeparator: Char;
ClassName,ObjectName,PropName: string;
Flags: TFilerFlags;
Position: Integer;
Val:Variant;
LastObj: TfrxComponent;
Parent: TfrxComponent;
isBin: Boolean;
Sig: AnsiString;
CurY: Extended;
DataBand: TfrxBand;
DSName: String;
Table : TfrxTableObject;
IndexCol : Integer ;
ICol : Integer ;
IRow : Integer ;
TabLeft : Double;
TabTop : Double;
Chart : TfrxChartView;
CrossTab : TfrxDBCrossView;
function GetBoolValue(Str: String): Boolean;
begin
Result := False;
If CompareStr(Str,'True') = 0 then
Result := True;
end;
procedure AssignReport();
var
Page: TfrxReportPage;
i: Integer;
begin
Page := LastObj as TfrxReportPage;
{Page property}
if PropName = 'PrinterSetup.mmPaperHeight' then
Page.PaperHeight := Val/1000
else if PropName = 'PrinterSetup.mmPaperWidth' then
Page.PaperWidth := Val/1000
else if PropName = 'PrinterSetup.mmMarginTop' then
Page.TopMargin := Val/1000
else if PropName = 'PrinterSetup.mmMarginBottom' then
Page.BottomMargin := Val/1000
else if PropName = 'PrinterSetup.mmMarginLeft' then
begin
Page.LeftMargin := Val/1000;
for i := 0 to Page.ColumnPositions.Count - 1 do
Page.ColumnPositions[i] := FloatToStr(StrToFloat(Page.ColumnPositions[i]) - Page.LeftMargin);
end
else if PropName = 'PrinterSetup.mmMarginRight' then
Page.RightMargin := Val/1000
else if PropName = 'PrinterSetup.PaperSize' then
Page.PaperSize := Val
else if PropName = 'PrinterSetup.BinName' then
Page.Bin := frxPrinters.Printer.BinNameToNumber(Val)
else if PropName = 'Columns' then
begin
Page.Columns := Val;
Page.ColumnPositions.Clear;
end
else if PropName = 'ColumnPositions.Strings' then
Page.ColumnPositions.Add(FloatToStr((StrToFloat(Val))/10000 * fr01in))
else if PropName = 'mmColumnWidth' then
Page.ColumnWidth := Val/10000 * fr01in
else if PropName = 'PrinterSetup.Orientation' then
Page.Orientation := TPrinterOrientation(GetEnumValue(TypeInfo(TPrinterOrientation), Val))
else if PropName = 'PrinterSetup.Duplex' then
Page.Duplex := TfrxDuplexMode(GetEnumValue(TypeInfo(TppDuplex),Val))
else if PropName = 'PrinterSetup.Copies' then
AReport.PrintOptions.Copies := Val
else if PropName = 'PrinterSetup.PrinterName' then
AReport.PrintOptions.Printer := Val
else if PropName = 'PrinterSetup.DocumentName' then
AReport.ReportOptions.Name := Val
else if PropName = 'DataPipeline' then
begin
i := pos('.', Val) + 1;
DSName := Val;
if i > 0 then
DSName := copy(Val, i, length(DSName) - i)
else DSName := '';
end;
end;
procedure AssignHeader();
var
Header: TfrxHeader;
begin
Header := LastObj as TfrxHeader;
if PropName = 'mmHeight' then
Header.Height := Val / 10000 * fr1cm
end;
procedure AssignDBProp;
var
View: TfrxView;
i: Integer;
begin
View := LastObj as TfrxView;
if PropName = 'DataPipeline' then
begin
i := pos('.', Val) + 1;
View.DataSetName := Val;
if i <> - 1 then
View.DataSetName := copy(Val, i, length(View.DataSetName) - i)
else View.DataSetName := '';
end
else
if PropName = 'DataField' then
View.DataField := Val
else if PropName = 'DataPipelineName' then
View.DataSetName := Val
end;
function GetCharsetByName(cName: String):TFontCharset;
begin
if cName = 'ANSI_CHARSET' then
Result := ANSI_CHARSET
else if cName = 'DEFAULT_CHARSET' then
Result := DEFAULT_CHARSET
else if cName = 'SYMBOL_CHARSET' then
Result := SYMBOL_CHARSET
else if cName = 'MAC_CHARSET' then
Result := MAC_CHARSET
else if cName = 'SHIFTJIS_CHARSET' then
Result := SHIFTJIS_CHARSET
else if cName = 'HANGEUL_CHARSET' then
Result := HANGEUL_CHARSET
else if cName = 'JOHAB_CHARSET' then
Result := JOHAB_CHARSET
else if cName = 'GB2312_CHARSET' then
Result := GB2312_CHARSET
else if cName = 'CHINESEBIG5_CHARSET' then
Result := CHINESEBIG5_CHARSET
else if cName = 'GREEK_CHARSET' then
Result := GREEK_CHARSET
else if cName = 'TURKISH_CHARSET' then
Result := TURKISH_CHARSET
else if cName = 'HEBREW_CHARSET' then
Result := HEBREW_CHARSET
else if cName = 'ARABIC_CHARSET' then
Result := ARABIC_CHARSET
else if cName = 'BALTIC_CHARSET' then
Result := BALTIC_CHARSET
else if cName = 'RUSSIAN_CHARSET' then
Result := RUSSIAN_CHARSET
else if cName = 'THAI_CHARSETT' then
Result := THAI_CHARSET
else if cName = 'EASTEUROPE_CHARSET' then
Result := EASTEUROPE_CHARSET
else if cName = 'OEM_CHARSET' then
Result := OEM_CHARSET
else
Result := 1;
end;
procedure AssignFont;
var
View: TfrxView;
begin
View := LastObj as TfrxView;
if View = nil then exit;
if PropName = 'Font.Charset' then
View.Font.Charset := GetCharsetByName(Val)
else if PropName = 'Font.Color' then
View.Font.Color := StringToColor(Val)
else if PropName = 'Font.Name' then
View.Font.Name := Val
else if PropName = 'Font.Size' then
View.Font.Size := Val
else if PropName = 'Font.Style' then
View.Font.Style := View.Font.Style + [TFontStyle(GetEnumValue(TypeInfo(TFontStyle), Val))]
end;
procedure AssignBandData;
var
B: TfrxDataBand;
begin
B := LastObj as TfrxDataBand;
if B = nil then exit;
B.DataSetName := DSName;
end;
procedure AssignBorder;
var
frxView: TfrxView;
begin
frxView := lastObj as TfrxView;
if frxView = nil then exit;
if PropName = 'Border.BorderPositions' then
frxView.Frame.Typ := frxView.Frame.Typ + [TfrxFrameType(GetEnumValue(TypeInfo(TppFrame),Val))]
else if PropName = 'Border.Color' then
frxView.Frame.Color := StringToColor(Val)
else if PropName = 'Border.Style' then
frxView.Frame.Style := TfrxFrameStyle(GetEnumValue(TypeInfo(TPenStyle),Val))
end;
procedure AssignMemo();
var
Memo: TfrxMemoView;
begin
Memo := LastObj as TfrxMemoView;
if (PropName = 'Caption') and (Memo.Text = '') then
Memo.Text := Val
else if PropName = 'UserName' then
Memo.Name := Val
else if PropName = 'Angle' then
Memo.Rotation := Val
else if PropName= 'Color' then
Memo.Color := StringToColor(Val)
else if PropName = 'CharWrap' then
Memo.WordWrap := Val
else if Pos('Border', PropName) = 1 then
AssignBorder
else if Pos('Font', PropName) = 1 then
AssignFont
else if PropName = 'BlankWhenZero' then
Memo.HideZeros := Val
else if PropName = 'SuppressRepeatedValues' then
Memo.SuppressRepeated := Val
else if PropName = 'TextAlignment' then
begin
if Val = 'taLeftJustified' then
Memo.HAlign := haLeft
else if Val = 'taRightJustified' then
Memo.HAlign := haRight
else if Val = 'taCentered' then
Memo.HAlign := haCenter
else if Val = 'taFullJustified' then
Memo.HAlign := haBlock;
end
else if PropName = 'WordWrap' then
Memo.WordWrap := Val
else if PropName = 'Stretch' then
begin
if Val then
Memo.StretchMode := smActualHeight
else
Memo.StretchMode := smDontStretch;
end
else if PropName = 'AutoSize' then
begin
Memo.AutoWidth := Val
end
else if PropName = 'Anchors' then
begin
if Val = 'atLeft' then
Memo.Anchors := Memo.Anchors + [fraLeft]
else if Val = 'atRight' then
Memo.Anchors := Memo.Anchors + [fraRight]
else if Val = 'atBottom' then
Memo.Anchors := Memo.Anchors + [fraBottom]
else if Val = 'atTop' then
Memo.Anchors := Memo.Anchors + [fraTop];
end
else if PropName = 'HyperLink' then
begin
Memo.Hyperlink.Value := Val
end
else if PropName = 'RTLReading' then
begin
Memo.RTLReading := Val
end
else if PropName = 'Caption' then
begin
Memo.Text := Val
end
else if PropName = 'Lines.Strings' then
Memo.Lines.Add(Val);
if (Pos('DB', ClassName) = 4) and (Memo.DataSetName <> '') and (Memo.DataField <> '') then
Memo.Text := '['+ Memo.DataSetName + '."' + Memo.DataField + '"]'
{DBCalcType}
end;
procedure AssignBarCode;
var
Bar: TfrxBarCodeView;
begin
Bar := LastObj as TfrxBarCodeView;
if Bar = nil then exit;
if PropName = 'BarCodeType' then
case GetEnumValue(TypeInfo(TppBarTypes),Val) of
0: Bar.BarType := bcCodeUPC_A;
1: Bar.BarType := bcCodeUPC_E0;
2: Bar.BarType := bcCodeEAN13;
3: Bar.BarType := bcCodeEAN8;
4: Bar.BarType := bcCode_2_5_interleaved;
5: Bar.BarType := TfrxBarcodeType(5);
6: Bar.BarType := TfrxBarcodeType(3);
7: Bar.BarType := bcCodePostNet;
8: Bar.BarType := bcCode_2_5_industrial;
9: Bar.BarType := bcCodeCodabar;
10: Bar.BarType := bcCodeMSI;
11: Bar.BarType := bcCodeUSPSIntelligentMail;
end
else if PropName = 'Data' then
Bar.Text := Val
//else if PropName = 'mmBarWidth' then
// Bar.Width := Val
else if PropName = 'mmWideBarRatio' then
Bar.WideBarRatio := round(Val/1000000 * fr1cm)
else if PropName = 'PrintHumanReadable' then
Bar.ShowText := Val
else if PropName = 'BarColorCalcCheckDigit' then
Bar.CalcCheckSum := Val
end;
procedure Assign2DBarcodeView();
var
BarCode: TfrxBarcode2DView;
begin
BarCode := LastObj as TfrxBarcode2DView;
if PropName = 'BarCodeType' then
case GetEnumValue(TypeInfo(Tpp2DBarTypes),Val) of
0: BarCode.BarType := bcCodePDF417;
1: BarCode.BarType := bcCodeMaxiCode;
2: BarCode.BarType := bcCodeQR;
3: BarCode.BarType := bcCodeDataMatrix;
4: BarCode.BarType := bcCodeAztec;
end
else if PropName = 'Data' then
BarCode.Text := Val
end;
procedure AssignTableView();
var
Table: TfrxTableObject;
begin
Table := LastObj as TfrxTableObject;
if PropName = 'ColCount' then
Table.ColumnCount := Val
else if PropName = 'RowCount' then
Table.RowCount := Val
end;
procedure ObjectCreator(Name:String);
begin
if Name = 'TppReport' then
begin
LastObj := TfrxReportPage.Create(AReport);
Parent := LastObj;
TfrxReportPage(LastObj).CreateUniqueName;
TfrxReportPage(LastObj).SetDefaults;
end
else if Name = 'TppHeaderBand' then
begin
LastObj := TfrxHeader.Create(Parent);
LastObj.CreateUniqueName;
end
else if Name = 'TppTitleBand' then
begin
LastObj := TfrxReportTitle.Create(Parent);
LastObj.CreateUniqueName;
end
else if Name = 'TppColumnHeaderBand' then
begin
LastObj := TfrxColumnHeader.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppLabel') or (Name = 'TppSystemVariable')
or (Name = 'TppVariable') or (Name = 'TppMemo')
or (Name = 'TppDBText') or (Name = 'TppDBMemo') or (Name = 'TppDBCalc') then
begin
LastObj := TfrxMemoView.Create(Parent);
LastObj.CreateUniqueName;
TfrxMemoView(LastObj).AutoWidth := true;
if (Name = 'TppSystemVariable') then
TfrxCustomMemoView(LastObj).Text := '[Date]';
end
else if (Name = 'TppImage') or (Name = 'TppDBImage') then
begin
LastObj := TfrxPictureView.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppShape') then
begin
LastObj := TfrxShapeView.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppDetailBand') then
begin
LastObj := TfrxMasterData.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppColumnHeaderBand') then
begin
LastObj := TfrxColumnHeader.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppColumnFooterBand') then
begin
LastObj := TfrxColumnFooter.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppFooterBand') then
begin
LastObj := TfrxFooter.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppSummaryBand') then
begin
LastObj := TfrxReportSummary.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppBarCode') or (Name = 'TppDBBarCode') then
begin
LastObj := TfrxBarCodeView.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppRichText') or (Name = 'TppDBRichText') then
begin
LastObj := TfrxRichView.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TmyCheckBox') or (Name = 'TmyDBCheckBox') then
begin
LastObj := TfrxCheckBoxView.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppLine') then
begin
LastObj := TfrxLineView.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppGroupHeaderBand') then
begin
LastObj := TfrxGroupHeader.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppGroupFooterBand') then
begin
LastObj := TfrxGroupFooter.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TdaSQL') then
begin
LastObj := TfrxADOQuery.Create(AReport.Pages[0]);
LastObj.CreateUniqueName;
end
else if (Name = 'TppGMap') then
begin
LastObj := TfrxMapView.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'Tpp2DBarCode') or (Name = 'TppDB2DBarCode') then
begin
LastObj := TfrxBarcode2DView.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppTableGrid') then
begin
LastObj := TfrxTableObject.Create(Parent);
LastObj.CreateUniqueName;
Table := TfrxTableObject(LastObj);
IndexCol := 0; ICol := 0; IRow := 0;
end
else if (Name = 'TppPaintBox') then
begin
LastObj := TfrxPictureView.Create(Parent);
LastObj.CreateUniqueName;
end
else if (Name = 'TppTeeChart') or (ClassName = 'TppDPTeeChart') then
begin
LastObj := TfrxChartView.Create(Parent);
LastObj.CreateUniqueName;
Chart := TfrxChartView(LastObj);
end
else if (Name = 'TppTableRow') then
begin
Table.RowCount := Table.RowCount + 1;
IndexCol := 0;
end
else if (Name = 'TppTableCell') then
begin
if Table.RowCount = 1 then
Table.ColumnCount := Table.ColumnCount + 1;
if (Table.RowCount > 0) and (Table.ColumnCount > 0) then
begin
LastObj := Table.Cells[IndexCol, Table.RowCount-1];
IndexCol := IndexCol +1;
end;
end
else if (ClassName = 'TppCrossTab') then
begin
LastObj := TfrxDBCrossView.Create(Parent);
LastObj.CreateUniqueName;
CrossTab := TfrxDBCrossView(LastObj);
end;
end;
procedure AssignView;
begin
if PropName = 'mmHeight' then
LastObj.Height := Val/10000 * fr1cm
else if PropName = 'mmWidth' then
LastObj.Width := Val/10000 * fr1cm
else if PropName = 'mmLeft' then
LastObj.Left := Val/10000 * fr1cm
else if PropName = 'mmTop' then
LastObj.Top := Val/10000 * fr1cm
else if PropName = 'Visible' then
LastObj.Visible := Val;
if LastObj.Parent is TfrxTableCell then
end;
procedure AssignADOQuery;
var
Query: TfrxADOQuery;
begin
Query := LastObj as TfrxADOQuery;
if Query = nil then exit;
if PropName = 'DataPipelineName' then
begin
Query.UserName := Val;
Query.Name := Val;
end
else if PropName = 'SQLText.Strings' then
Query.SQL.Add(Val)
end;
procedure AssignPicture;
var
Stream: TMemoryStream;
Cn: Integer;
begin
if PropName = 'Picture.Data' then
begin
Stream := TMemoryStream.Create;
Cn := 0;
TMemoryStream(frxInteger(Val)).Position := 0;
TMemoryStream(frxInteger(Val)).Read(Cn, 1);
TMemoryStream(frxInteger(Val)).Position := Cn + 1;
Stream.SetSize(TMemoryStream(frxInteger(Val)).Size - (Cn + 1));
Stream.CopyFrom(TMemoryStream(frxInteger(Val)), Stream.Size);
TfrxPictureView(LastObj).LoadPictureFromStream(Stream);
Stream.Free;
end
else if PropName = 'AutoSize' then
TfrxPictureView(LastObj).AutoSize := Val
else if PropName = 'Stretch' then
TfrxPictureView(LastObj).Stretched := Val
else if PropName = 'Anchors' then
begin
if Val = 'atLeft' then
TfrxPictureView(LastObj).Anchors := TfrxPictureView(LastObj).Anchors + [fraLeft]
else if Val = 'atRight' then
TfrxPictureView(LastObj).Anchors := TfrxPictureView(LastObj).Anchors + [fraRight]
else if Val = 'atBottom' then
TfrxPictureView(LastObj).Anchors := TfrxPictureView(LastObj).Anchors + [fraBottom]
else if Val = 'atTop' then
TfrxPictureView(LastObj).Anchors := TfrxPictureView(LastObj).Anchors + [fraTop];
end
else if PropName = 'HyperLink' then
begin
TfrxPictureView(LastObj).Hyperlink.Value := Val
end
end;
procedure AssignProp;
var Item : TfrxComponent;
begin
if Pos('DB', ClassName) = 4 then
AssignDBProp;
if (PropName = 'UserName') and not (LastObj is TfrxPage)
and not (ClassName = 'TppTableRow') and not (ClassName = 'TppTableCell')
and not (ClassName = 'TppTableColumn')then
LastObj.Name := Val
else if ClassName = 'TppReport' then
AssignReport
{ else if ClassName = 'TppHeaderBand' then
AssignHeader }
else if (ClassName = 'TppTitleBand') or (ClassName = 'TppColumnHeaderBand') or (ClassName = 'TppDetailBand')
or (ClassName = 'TppColumnHeaderBand') or ( ClassName = 'TppColumnFooterBand') or (ClassName = 'TppFooterBand')
or (ClassName = 'TppSummaryBand') or (ClassName = 'TppHeaderBand') or (ClassName = 'TppGroupHeaderBand')
or (ClassName = 'TppGroupFooterBand') then
begin
if ClassName = 'TppDetailBand' then
AssignBandData;
if PropName = 'mmHeight' then
begin
TfrxBand(LastObj).Top := CurY;
TfrxBand(LastObj).Height := Val / 10000 * fr1cm;
CurY := CurY + TfrxBand(LastObj).Height + 1;
end
else if PropName = 'Visible' then
LastObj.Visible := Val
else if PropName = 'Tag' then
LastObj.Tag := Val
else if (ClassName = 'TppGroupHeaderBand') then
begin
if DataBand <> nil then
begin
DataBand.FGroup := TfrxGroupHeader(LastObj);
LastObj.Top := DataBand.Top ;
end
end
else if (ClassName = 'TppGroupFooterBand') then
begin
if DataBand <> nil then
begin
LastObj.Top := DataBand.Top + DataBand.Height;
end
end
else if (ClassName = 'TppDetailBand') then
DataBand := LastObj as TfrxBand
else if(ClassName = 'TppSummaryBand') then
if PropName = 'NewPage' then
TfrxReportSummary(LastObj).StartNewPage := Val;
end
else if (ClassName = 'TppLabel')
or (ClassName = 'TppMemo') or (ClassName = 'TppDBText') or (ClassName = 'TppDBCalc')
or (ClassName = 'TppDBMemo') then
begin
AssignView;
AssignMemo;
end
else if (ClassName = 'TppSystemVariable') then
begin
AssignView;
AssignMemo;
if PropName = 'VarType' then
case TRBVarType(GetEnumValue(TypeInfo(TRBVarType),Val)) of
vtDate : TfrxCustomMemoView(LastObj).Text := '[Date]';
vtDateTime : TfrxCustomMemoView(LastObj).Text := '[Now]';
vtDocumentName : TfrxCustomMemoView(LastObj).Text := '[Report.ReportOptions.Name]';
vtPrintDateTime : TfrxCustomMemoView(LastObj).Text := 'PrintDateTime does not exist in Fast Report';
vtPageCount : TfrxCustomMemoView(LastObj).Text := '[TotalPages#]';
vtPageSet : TfrxCustomMemoView(LastObj).Text := '[Page#] of [TotalPages#]';
vtPageSetDesc : TfrxCustomMemoView(LastObj).Text := 'Page [Page#] of [TotalPages#]';
vtPageNo : TfrxCustomMemoView(LastObj).Text := '[Page#]';
vtPageNoDesc : TfrxCustomMemoView(LastObj).Text := 'Page [Page#]';
vtTime : TfrxCustomMemoView(LastObj).Text := '[Time]';
else TfrxCustomMemoView(LastObj).Text := 'Unknown Variable';
end;
end
else if (ClassName = 'TppVariable') then
begin
AssignView;
AssignMemo;
if AReport.Variables.IndexOf(RBVarsCat) = -1 then
with AReport.Variables.Add do
begin
Name := RBVarsCat;
Value := Null;
end;
AReport.Variables.AddVariable('RBVariables', 'Report' + LastObj.Name, '''' + '''');
TfrxCustomMemoView(LastObj).Text := '[Report' + LastObj.Name + ']';
end
else if (ClassName = 'TppImage') or (ClassName = 'TppDBImage') then
begin
AssignView;
AssignBorder;
AssignPicture;
end
else if (ClassName = 'TppShape') then
begin
AssignView;
if PropName = 'Shape' then
begin
TfrxShapeView(LastObj).Shape := TfrxShapeKind(GetEnumValue(TypeInfo(TShapeType),Val));
if (Val = 'stRoundRect') or (Val = 'stRoundSquare') then
TfrxShapeView(LastObj).Curve := 2;
end;
if PropName= 'Brush.Color' then
TfrxShapeView(LastObj).Color := StringToColor(Val)
end
else if (ClassName = 'TppBarCode') or (ClassName = 'TppDBBarCode') then
begin
AssignView;
AssignBorder;
AssignBarCode;
end
else if (ClassName = 'TppRichText') or (ClassName = 'TppDBRichText') then
begin
AssignView;
AssignBorder;
if PropName = 'RichText' then
TfrxRichView(LastObj).RichEdit.Text := String(Val)
else if PropName = 'Stretch' then
begin
if Val then
TfrxRichView(LastObj).StretchMode := smActualHeight
else
TfrxRichView(LastObj).StretchMode := smDontStretch;
end
end
else if (ClassName = 'TmyCheckBox') or (ClassName = 'TmyDBCheckBox') then
begin
AssignView;
AssignBorder;
end
else if (ClassName ='TppLine') then
begin
AssignView;
AssignBorder;
end
else if (ClassName = 'TdaSQL') then
begin
AssignView;
AssignADOQuery;
end
else if (ClassName = 'TppGMap') then
begin
AssignView;
AssignBorder
end
else if (ClassName = 'Tpp2DBarCode') or (ClassName = 'TppDB2DBarCode') then
begin
AssignView;
AssignBorder;
Assign2DBarcodeView;
end
else if (ClassName = 'TppTableGrid') then
begin
AssignView;
AssignBorder;
AssignTableView;
end
else if (ClassName = 'TppPaintBox') then
begin
AssignView;
AssignBorder;
end
else if ((ClassName = 'TppTeeChart') or (ClassName = 'TppDPTeeChart')) then
begin
AssignView;
AssignBorder;
end
else if (ClassName = 'TppTableRow') then
begin
if PropName = 'mmHeight' then
Table.Rows[Table.RowCount - 1].Height := Val/10000 * fr1cm;
end
else if (ClassName = 'TppTableColumn') then
begin
if PropName = 'mmWidth' then
begin
Table.Columns[ICol].Width := Val/10000 * fr1cm ;
if ICol = 0 then
TabLeft := Table.Left
else
TabLeft := TabLeft + Table.Columns[ICol-1].Width;
if IRow = 0 then
TabTop := Table.Top;
while IRow < Table.RowCount do
begin
for Item in Table.Cells[ICol,IRow].Objects do
begin
Item.Left := Item.Left - TabLeft;
Item.Top := Item.Top - TabTop;
end;
TabTop := TabTop + Table.Rows[IRow].Height;
IRow := IRow + 1;
end;
ICol := ICol + 1;
IRow := 0;
end;
end
else if (ClassName = 'TppCrossTab') then
begin
AssignView;
AssignBorder;
end
else if (ClassName = 'TppValueDef') then
begin
if PropName = 'FieldName' then
begin
CrossTab.CellFields.Add(Val);
CrossTab.CellLevels := CrossTab.CellLevels + 1;
end;
end
else if (ClassName = 'TppColumnDef') then
begin
if PropName = 'FieldName' then
begin
CrossTab.ColumnFields.Add(Val);
CrossTab.ColumnLevels := CrossTab.ColumnLevels + 1;
end;
end
else if (ClassName = 'TppRowDef') then
begin
if PropName = 'FieldName' then
begin
CrossTab.RowFields.Add(Val);
CrossTab.RowLevels := CrossTab.ColumnLevels + 1;
end;
end
end;
procedure ConvertBinary;
var
Count: Longint;
Stream: TMemoryStream;
begin
Reader.ReadValue;
Reader.Read(Count, SizeOf(Count));
Stream := TMemoryStream.Create;
Stream.SetSize(Count);
Reader.Read(Stream.Memory^, Count);
Val := frxInteger(Stream);
end;
procedure ReadProperty; forward;
procedure ConvertValue;
var
L: Integer;
S: string;
W: WideString;
begin
case Reader.NextValue of
vaList:
begin
Reader.ReadValue;
while not Reader.EndOfList do
begin
ConvertValue;
end;
Reader.ReadListEnd;
exit;
end;
vaInt8, vaInt16, vaInt32:
Val := IntToStr(Reader.ReadInteger);
vaExtended:
Val := FloatToStrF(Reader.ReadFloat, ffFixed, 16, 18);
vaSingle:
Val := FloatToStr(Reader.ReadSingle) + 's';
vaCurrency:
Val := FloatToStr(Reader.ReadCurrency * 10000) + 'c';
vaDate:
Val := FloatToStr(Reader.ReadDate) + 'd';
vaWString, vaUTF8String:
begin
W := Reader.ReadWideString;
L := Length(W);
if L = 0 then W := '';
Val := W;
end;
vaString, vaLString:
begin
S := Reader.ReadString;
L := Length(S);
if L = 0 then S := '';
Val := S;
end;
vaIdent, vaFalse, vaTrue, vaNil, vaNull:
Val := Reader.ReadIdent;
vaBinary:
begin
isBin := True;
ConvertBinary;
end;
vaSet:
begin
Reader.ReadValue;
while True do
begin
S := Reader.ReadStr;
if S = '' then exit;
Val := S;
AssignProp;
end;
end;
vaCollection:
begin
Reader.ReadValue;
while not Reader.EndOfList do
begin
if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
begin
ConvertValue;
end;
Reader.CheckValue(vaList);
while not Reader.EndOfList do ReadProperty;
Reader.ReadListEnd;
end;
Reader.ReadListEnd;
end;
vaInt64:
Val := IntToStr(Reader.ReadInt64);
end;
AssignProp;
end;
procedure ReadProperty;
begin
PropName := Reader.ReadStr;
ConvertValue;
end;
procedure ReadObject;
var
LastParent: TfrxComponent;
Ch : TChart;
ReaderChart: TReader;
Series : TChartSeries;
st: string;
indSeriesVal : Integer;
SeriesItem : TfrxSeriesItem;
OldAStreamPosition : Integer;
begin
if ((ClassName = 'TppTeeChart') or (ClassName = 'TppDPTeeChart'))
and (PropName = 'LayerName') then
begin
OldAStreamPosition := AStream.Position;
AStream.Position := Reader.Position;
ReaderChart := TReader.Create(AStream, 4096);
ReaderChart.OnFindComponentClass := Reader.OnFindComponentClass;
Ch := TChart.Create(nil);
ReaderChart.Root := Chart.Chart;
ReaderChart.Parent := nil;
FreeAndNil(Ch);
ReaderChart.BeginReferences;
try
Ch := ReaderChart.ReadComponent(Chart.Chart) as TChart;
for Series in Ch.SeriesList do
begin
Chart.SeriesData.Add;
if (ClassName = 'TppDPTeeChart') then
begin
Chart.SeriesData.Items[Chart.SeriesData.Count-1].DataType := dtDBData;
Chart.SeriesData.Items[Chart.SeriesData.Count-1].Source1:=
'."' + Series.XLabelsSource + '"';
Chart.SeriesData.Items[Chart.SeriesData.Count-1].Source2:=
'."' + Series.YValues.ValueSource + '"';
Chart.SeriesData.Items[Chart.SeriesData.Count-1].Source3:=
'."' + Series.XValues.ValueSource + '"';
end
else
for indSeriesVal := 0 to Series.XValues.Count-1 do
begin
Chart.SeriesData.Items[Chart.SeriesData.Count-1].DataType := dtFixedData;
Chart.SeriesData.Items[Chart.SeriesData.Count-1].Source1:=
Chart.SeriesData.Items[Chart.SeriesData.Count-1].Source1 +';'+
Series.XValues.Value[indSeriesVal].ToString;
Chart.SeriesData.Items[Chart.SeriesData.Count-1].Source2:=
Chart.SeriesData.Items[Chart.SeriesData.Count-1].Source2 +';'+
Series.YValues.Value[indSeriesVal].ToString;
end;
indSeriesVal :=0;
end;
finally
ReaderChart.FixupReferences;
ReaderChart.EndReferences;
FreeAndNil(ReaderChart);
end;
AStream.Position := OldAStreamPosition;
end;
Reader.ReadPrefix(Flags, Position);
if (ffInherited in Flags) or (ffInline in Flags) then exit;
ClassName := Reader.ReadStr;
ObjectName := Reader.ReadStr;
ObjectCreator(ClassName);
LastParent := LastObj;
while not Reader.EndOfList do
begin
ReadProperty;
if PropName = 'DataSource' then
begin
for indSeriesVal := 0 to Chart.SeriesData.Count-1 do
begin
if Chart.Chart.Series[indSeriesVal].Name = ObjectName then
begin
SeriesItem := Chart.SeriesData.Items[indSeriesVal];
SeriesItem.Source1 := Val + SeriesItem.Source1;
SeriesItem.Source2 := Val + SeriesItem.Source2;
SeriesItem.Source3 := Val + SeriesItem.Source3;
end;
end;
end;
if isBin then
begin
TMemoryStream(frxInteger(Val)).Free;
isBin := False;
end;
end;
if (LastObj <> nil) and (LastObj.Parent <> nil) and not (LastObj.Parent is TfrxReport)
and not (LastObj.Parent is TfrxChartView) then
LastObj := LastObj.Parent;
Reader.ReadListEnd;
while not Reader.EndOfList do
begin
Parent := LastParent;
ReadObject;
end;
Reader.ReadListEnd;
end;
begin
Result := False;
SetLength(Sig, 3);
AStream.Position := 0;
AStream.Read(Sig[1], 3);
AStream.Position := 0;
if Sig <> 'TPF' then exit;
AReport.Clear;
with TfrxDataPage.Create(AReport) do
begin
CreateUniqueName;
end;
Reader := TReader.Create(AStream, 4096);
Reader.OnFindComponentClass := MyEvent.OnFindComponentClass;
{$IFDEF Delphi16}
SaveSeparator := FormatSettings.DecimalSeparator;
{$ELSE}
SaveSeparator := DecimalSeparator;
{$ENDIF}
isBin := False;
CurY := 0;
{$IFDEF Delphi16}
FormatSettings.DecimalSeparator := '.';
{$ELSE}
DecimalSeparator := '.';
{$ENDIF}
try
Reader.ReadSignature;
Reader.ReadPrefix(Flags, Position);
LastObj := nil;
ReadObject;
Result := True;
finally
Reader.Free;
end;
{$IFDEF Delphi16}
FormatSettings.DecimalSeparator := SaveSeparator;
{$ELSE}
DecimalSeparator := SaveSeparator;
{$ENDIF}
end;
function TfrxFR2EventsNew.DoLoad(Sender: TfrxReport; Stream: TStream): Boolean;
var
Sig: AnsiString;
TmpStream: TMemoryStream;
begin
SetLength(Sig, 6);
Stream.Position := 0;
Stream.Read(Sig[1], 6);
Stream.Position := 0;
if Sig = 'object' then
begin
TmpStream := TMemoryStream.Create;
try
ObjectTextToBinary(Stream, TmpStream);
Result := LoadFromRB(Sender, TmpStream, Self);
finally
TmpStream.Free;
end;
end
else
Result := LoadFromRB(Sender, Stream, Self);
end;
procedure TfrxFR2EventsNew.OnFindComponentClass(Reader: TReader;
const ClassName: string; var ComponentClass: TComponentClass);
begin
if (ClassName = 'TppTeeChartControl') or (ClassName = 'TppDPTeeChartControl') then
ComponentClass := TChart;
end;
initialization
frxFR2EventsNew := TfrxFR2EventsNew.Create;
frxFR2Events.OnLoad := frxFR2EventsNew.DoLoad;
frxFR2Events.Filter := '*.rtm';
finalization
frxFR2EventsNew.Free;
end.
Reference in New Issue Copy Permalink