{******************************************} { } { 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.