david
3b72eb27ca
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.FastReport@22 475b051d-3a53-6940-addd-820bf0cfe0d7
723 lines
21 KiB
ObjectPascal
723 lines
21 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ FastReport v4.0 }
|
|
{ RB -> FR importer }
|
|
{ }
|
|
{ Copyright (c) 1998-2008 }
|
|
{ Fast Reports Inc. }
|
|
{ }
|
|
{******************************************}
|
|
|
|
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,
|
|
TeeProcs, TeEngine, Chart, Series, frxChart, frxChBox, frxOLE, frxRich,
|
|
frxCross, frxDBSet, frxUnicodeUtils, frxUtils, fs_ipascal,
|
|
frxCustomDB, frxBDEComponents, frxADOComponents, frxIBXComponents
|
|
{$IFDEF Delphi6}
|
|
, Variants
|
|
{$ENDIF};
|
|
|
|
|
|
type
|
|
TfrxFR2EventsNew = class(TObject)
|
|
private
|
|
function DoLoad(Sender: TfrxReport; Stream: TStream): Boolean;
|
|
end;
|
|
|
|
TppDuplex = (dpNone, dpHorizontal, dpVertical);
|
|
TppFrame = (bpLeft, bpRight, bpTop, bpBottom);
|
|
TShapeType = (stRectangle, stRoundRect, stEllipse, stSquare, stRoundSquare ,stCircle);
|
|
TppBarTypes = (bcUPC_A, bcUPC_E, bcEAN_13, bcEAN_8, bcInt2of5, bcCode128, bcCode39, bcPostnet, bcFIM, bcCodabar, bcMSI);
|
|
|
|
TAssignProp = procedure ();
|
|
|
|
var
|
|
frxFR2EventsNew: TfrxFR2EventsNew;
|
|
|
|
|
|
function LoadFromRB(AReport: TfrxReport; AStream: TStream): Boolean;
|
|
Var
|
|
Report: TfrxReport;
|
|
Reader: TReader;
|
|
SaveSeparator: Char;
|
|
ClassName,ObjectName,PropName: string;
|
|
Flags: TFilerFlags;
|
|
Position: Integer;
|
|
Val:Variant;
|
|
LastObj: TfrxComponent;
|
|
Parent: TfrxComponent;
|
|
isBin: Boolean;
|
|
Sig: String;
|
|
CurY: Extended;
|
|
DataBand: TfrxBand;
|
|
|
|
|
|
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
|
|
Report.PrintOptions.Copies := Val
|
|
else if PropName = 'PrinterSetup.PrinterName' then
|
|
Report.PrintOptions.Printer := Val
|
|
else if PropName = 'PrinterSetup.DocumentName' then
|
|
Report.ReportOptions.Name := Val;
|
|
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;
|
|
begin
|
|
View := LastObj as TfrxView;
|
|
if PropName = 'DataPipeline' then
|
|
View.DataSetName := Val
|
|
else if PropName = 'DataField' then
|
|
View.DataField := 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 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 = 'mmHeight' then
|
|
Memo.Height := Val/10000 * fr1cm
|
|
else if PropName = 'mmWidth' then
|
|
Memo.Width := Val/10000 * fr1cm
|
|
else if PropName = 'mmLeft' then
|
|
Memo.Left := Val/10000 * fr1cm
|
|
else if PropName = 'mmTop' then
|
|
Memo.Top := Val/10000 * fr1cm
|
|
else 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 = '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 := bcCode128A;
|
|
6: Bar.BarType := TfrxBarcodeType(12);
|
|
7: Bar.BarType := bcCodePostNet;
|
|
8: Bar.BarType := bcCode_2_5_industrial;
|
|
9: Bar.BarType := bcCodeCodabar;
|
|
10: Bar.BarType := bcCodeMSI;
|
|
end
|
|
else if PropName = 'Data' then
|
|
Bar.Text := Val
|
|
else if PropName = 'mmBarWidth' then
|
|
Bar.Width := Val
|
|
else if PropName = 'mmWideBarRatio' then
|
|
Bar.WideBarRatio := Val
|
|
else if PropName = 'PrintHumanReadable' then
|
|
Bar.ShowText := Val
|
|
else if PropName = 'BarColorCalcCheckDigit' then
|
|
Bar.CalcCheckSum := Val
|
|
end;
|
|
|
|
procedure ObjectCreator(Name:String);
|
|
begin
|
|
if Name = 'TppReport' then
|
|
begin
|
|
LastObj := TfrxReportPage.Create(Report);
|
|
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;
|
|
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 LastObj.Parent <> nil then
|
|
LastObj := LastObj.Parent;
|
|
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
|
|
end;
|
|
|
|
procedure AssignPicture;
|
|
var
|
|
Stream: TMemoryStream;
|
|
Cn: Integer;
|
|
begin
|
|
if PropName = 'Picture.Data' then
|
|
begin
|
|
Stream := TMemoryStream.Create;
|
|
Cn := 0;
|
|
TMemoryStream(Integer(Val)).Position := 0;
|
|
TMemoryStream(Integer(Val)).Read(Cn, 1);
|
|
TMemoryStream(Integer(Val)).Position := Cn + 5;
|
|
Stream.SetSize(TMemoryStream(Integer(Val)).Size - (Cn + 5));
|
|
Stream.CopyFrom(TMemoryStream(Integer(Val)), Stream.Size);
|
|
TfrxPictureView(LastObj).LoadPictureFromStream(Stream);
|
|
Stream.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure AssignProp;
|
|
begin
|
|
if Pos('DB', ClassName) = 4 then
|
|
AssignDBProp;
|
|
if PropName = 'UserName' 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 PropName = 'mmHeight' then
|
|
begin
|
|
TfrxBand(LastObj).Top := CurY;
|
|
TfrxBand(LastObj).Height := Val / 10000 * fr1cm;
|
|
CurY := CurY + TfrxBand(LastObj).Height;
|
|
end
|
|
else if PropName = 'Visible' then
|
|
LastObj.Visible := Val
|
|
else if (ClassName = 'TppGroupHeaderBand') then
|
|
begin
|
|
if DataBand <> nil then
|
|
begin
|
|
DataBand.FGroup := TfrxGroupHeader(LastObj);
|
|
end
|
|
end
|
|
else if (ClassName = 'TppGroupFooterBand') then
|
|
begin
|
|
//
|
|
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 = 'TppSystemVariable') or (ClassName = 'TppVariable')
|
|
or (ClassName = 'TppMemo') or (ClassName = 'TppDBText') or (ClassName = 'TppDBCalc')
|
|
or (ClassName = 'TppDBMemo') then
|
|
AssignMemo
|
|
else if (ClassName = 'TppImage') or (ClassName = 'TppDBImage') then
|
|
begin
|
|
AssignView;
|
|
AssignBorder;
|
|
AssignPicture;
|
|
end
|
|
else if (ClassName = 'TppShape') then
|
|
begin
|
|
AssignView;
|
|
if PropName = 'Shape' then
|
|
if TShapeType(GetEnumValue(TypeInfo(TShapeType),Val)) in [stRectangle, stRoundRect, stEllipse] then
|
|
TfrxShapeView(LastObj).Shape := TfrxShapeKind(GetEnumValue(TypeInfo(TPenStyle),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
|
|
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 := Integer(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;
|
|
begin
|
|
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 isBin then
|
|
begin
|
|
TMemoryStream(Integer(Val)).Free;
|
|
isBin := False;
|
|
end;
|
|
end;
|
|
Reader.ReadListEnd;
|
|
while not Reader.EndOfList do
|
|
begin
|
|
Parent := LastParent;
|
|
ReadObject;
|
|
end;
|
|
Reader.ReadListEnd;
|
|
end;
|
|
begin
|
|
Result := False;
|
|
Report := AReport;
|
|
Report.Clear;
|
|
SetLength(Sig, 3);
|
|
AStream.Position := 0;
|
|
AStream.Read(Sig[1], 3);
|
|
AStream.Position := 0;
|
|
if Sig <> 'TPF' then exit;
|
|
Reader := TReader.Create(AStream, 4096);
|
|
SaveSeparator := DecimalSeparator;
|
|
isBin := False;
|
|
CurY := 0;
|
|
DecimalSeparator := '.';
|
|
try
|
|
Reader.ReadSignature;
|
|
Reader.ReadPrefix(Flags, Position);
|
|
ReadObject;
|
|
Result := True;
|
|
finally
|
|
Reader.Free;
|
|
end;
|
|
DecimalSeparator := SaveSeparator;
|
|
end;
|
|
|
|
function TfrxFR2EventsNew.DoLoad(Sender: TfrxReport; Stream: TStream): Boolean;
|
|
var
|
|
Sig: String;
|
|
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);
|
|
finally
|
|
TmpStream.Free;
|
|
end;
|
|
end
|
|
else
|
|
Result := LoadFromRB(Sender, Stream);
|
|
end;
|
|
|
|
|
|
|
|
initialization
|
|
frxFR2EventsNew := TfrxFR2EventsNew.Create;
|
|
frxFR2Events.OnLoad := frxFR2EventsNew.DoLoad;
|
|
frxFR2Events.Filter := '*.rtm';
|
|
|
|
finalization
|
|
frxFR2EventsNew.Free;
|
|
|
|
|
|
end.
|
|
|
|
//
|