{******************************************} { } { FastReport v4.0 } { FR2.x importer } { } { Copyright (c) 1998-2007 } { by Alexander Tzyganenko, } { Fast Reports Inc. } { } {******************************************} unit frx2xto30; 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 FReport: TfrxReport; procedure DoGetValue(const Expr: String; var Value: Variant); procedure DoPrepareScript(Sender: TObject); function GetScriptValue(Instance: TObject; ClassType: TClass; const MethodName: String; var Params: Variant): Variant; function DoLoad(Sender: TfrxReport; Stream: TStream): Boolean; function DoGetScriptValue(var Params: Variant): Variant; end; TfrPageType = (ptReport, ptDialog); TfrBandType = (btReportTitle, btReportSummary, btPageHeader, btPageFooter, btMasterHeader, btMasterData, btMasterFooter, btDetailHeader, btDetailData, btDetailFooter, btSubDetailHeader, btSubDetailData, btSubDetailFooter, btOverlay, btColumnHeader, btColumnFooter, btGroupHeader, btGroupFooter, btCrossHeader, btCrossData, btCrossFooter, btChild, btNone); TfrxFixupItem = class(TObject) public Obj: TPersistent; PropInfo: PPropInfo; Value: String; end; TfrHighlightAttr = packed record FontStyle: Word; FontColor, FillColor: TColor; end; TfrBarCodeRec = packed record cCheckSum : Boolean; cShowText : Boolean; cCadr : Boolean; cBarType : TfrxBarcodeType; cModul : Integer; cRatio : Double; cAngle : Double; end; TChartOptions = packed record ChartType: Byte; Dim3D, IsSingle, ShowLegend, ShowAxis, ShowMarks, Colored: Boolean; MarksStyle: Byte; Top10Num: Integer; Reserved: array[0..35] of Byte; end; TfrRoundRect = packed record SdColor: TColor; // Color of Shadow wShadow: Integer; // Width of shadow Cadre : Boolean; // Frame On/Off - not used /TZ/ sCurve : Boolean; // RoundRect On/Off wCurve : Integer; // Curve size end; THackControl = class(TControl) end; TSeriesClass = class of TChartSeries; const gtMemo = 0; gtPicture = 1; gtBand = 2; gtSubReport = 3; gtLine = 4; gtCross = 5; gtAddIn = 10; frftNone = 0; frftRight = 1; frftBottom = 2; frftLeft = 4; frftTop = 8; frtaLeft = 0; frtaRight = 1; frtaCenter = 2; frtaVertical = 4; frtaMiddle = 8; frtaDown = 16; flStretched = 1; flWordWrap = 2; flWordBreak = 4; flAutoSize = 8; flTextOnly = $10; flSuppressRepeated = $20; flHideZeros = $40; flUnderlines = $80; flRTLReading = $100; flBandNewPageAfter = 2; flBandPrintifSubsetEmpty = 4; flBandBreaked = 8; flBandOnFirstPage = $10; flBandOnLastPage = $20; flBandRepeatHeader = $40; flBandPrintChildIfInvisible = $80; flPictCenter = 2; flPictRatio = 4; flWantHook = $8000; flDontUndo = $4000; flOnePerPage = $2000; pkNone = 0; pkBitmap = 1; pkMetafile = 2; pkIcon = 3; pkJPEG = 4; var frVersion: Byte; Report: TfrxReport; Stream: TStream; Page: TfrxPage; Fixups: TList; offsx, offsy: Integer; frxFR2EventsNew: TfrxFR2EventsNew; const frSpecCount = 9; frSpecFuncs: array[0..frSpecCount - 1] of String = ('PAGE#', '', 'DATE', 'TIME', 'LINE#', 'LINETHROUGH#', 'COLUMN#', 'CURRENT#', 'TOTALPAGES'); Bands: array[TfrBandType] of TfrxBandClass = (TfrxReportTitle, TfrxReportSummary, TfrxPageHeader, TfrxPageFooter, TfrxHeader, TfrxMasterData, TfrxFooter, TfrxHeader, TfrxDetailData, TfrxFooter, TfrxHeader, TfrxSubDetailData, TfrxFooter, TfrxOverlay, TfrxColumnHeader, TfrxColumnFooter, TfrxGroupHeader, TfrxGroupFooter, TfrxHeader, TfrxMasterData, TfrxFooter, TfrxChild, nil); cbDefaultText = '12345678'; ChartTypes: array[0..5] of TSeriesClass = (TLineSeries, TAreaSeries, TPointSeries, TBarSeries, THorizBarSeries, TPieSeries); frRepInfoCount = 9; frRepInfo: array[0..frRepInfoCount-1] of String = ('REPORTCOMMENT', 'REPORTNAME', 'REPORTAUTOR', 'VMAJOR', 'VMINOR', 'VRELEASE', 'VBUILD', 'REPORTDATE', 'REPORTLASTCHANGE'); ParamTypes: array[0..10] of TFieldType = (ftBCD, ftBoolean, ftCurrency, ftDate, ftDateTime, ftInteger, ftFloat, ftSmallint, ftString, ftTime, ftWord); procedure frGetDataSetAndField(ComplexName: String; var DataSet: TDataSet; var Field: String); forward; function frGetFieldValue(F: TField): Variant; forward; procedure LoadFromFR2Stream(AReport: TfrxReport; AStream: TStream); forward; function ConvertDatasetAndField(s: String): String; forward; { ------------------ hack FR events --------------------------------------- } { TfrxFR2EventsNew } procedure TfrxFR2EventsNew.DoGetValue(const Expr: String; var Value: Variant); var Dataset: TDataset; s, Field: String; tf: TField; ds: TfrxDataSet; fld: String; begin Dataset := nil; Field := ''; if CompareText(Expr, 'COLUMN#') = 0 then Value := Report.Engine.CurLine else begin s := Expr; if Pos('DialogForm.', s) = 1 then begin Delete(s, 1, Length('DialogForm.')); Report.GetDataSetAndField(s, ds, fld); if (ds <> nil) and (fld <> '') then begin Value := ds.Value[fld]; if Report.EngineOptions.ConvertNulls and (Value = Null) then case ds.FieldType[fld] of fftNumeric: Value := 0; fftString: Value := ''; fftBoolean: Value := False; end; Exit; end; end; frGetDataSetAndField(s, Dataset, Field); if (Dataset <> nil) and (Field <> '') then begin tf := Dataset.FieldByName(Field); Value := frGetFieldValue(tf); end; end; end; procedure TfrxFR2EventsNew.DoPrepareScript(Sender: TObject); var i: Integer; begin FReport := TfrxReport(Sender); Report := FReport; for i := 0 to FReport.Variables.Count - 1 do if IsValidIdent(FReport.Variables.Items[i].Name) then FReport.Script.AddMethod('function ' + FReport.Variables.Items[i].Name + ': Variant', GetScriptValue); end; function TfrxFR2EventsNew.GetScriptValue(Instance: TObject; ClassType: TClass; const MethodName: String; var Params: Variant): Variant; var i: Integer; val: Variant; begin i := FReport.Variables.IndexOf(MethodName); if i <> -1 then begin val := FReport.Variables.Items[i].Value; if (TVarData(val).VType = varString) or (TVarData(val).VType = varOleStr) then begin if Pos(#13#10, val) <> 0 then Result := val else Result := FReport.Calc(val); end else Result := val; end; end; function TfrxFR2EventsNew.DoLoad(Sender: TfrxReport; Stream: TStream): Boolean; begin Result := False; Stream.Read(frVersion, 1); Stream.Seek(-1, soFromCurrent); if frVersion < 30 then begin LoadFromFR2Stream(Sender, Stream); Result := True; end; end; function TfrxFR2EventsNew.DoGetScriptValue(var Params: Variant): Variant; begin Result := FReport.Calc('`' + Params[0] + '`', FReport.Script.ProgRunning); end; { ------------------ fixups ----------------------------------------------- } procedure ClearFixups; begin while Fixups.Count > 0 do begin TfrxFixupItem(Fixups[0]).Free; Fixups.Delete(0); end; end; procedure FixupReferences; var i: Integer; Item: TfrxFixupItem; Ref: TObject; begin for i := 0 to Fixups.Count - 1 do begin Item := Fixups[i]; Ref := Report.FindObject(Item.Value); if Ref <> nil then SetOrdProp(Item.Obj, Item.PropInfo, Integer(Ref)); end; ClearFixups; end; procedure AddFixup(Obj: TPersistent; Name, Value: String); var Item: TfrxFixupItem; begin Item := TfrxFixupItem.Create; Item.Obj := Obj; Item.PropInfo := GetPropInfo(Obj.ClassInfo, Name); Item.Value := Value; Fixups.Add(Item); end; { ------------------ stream readers -------------------------------------- } function frSetFontStyle(Style: Integer): TFontStyles; begin Result := []; if (Style and $1) <> 0 then Result := Result + [fsItalic]; if (Style and $2) <> 0 then Result := Result + [fsBold]; if (Style and $4) <> 0 then Result := Result + [fsUnderLine]; if (Style and $8) <> 0 then Result := Result + [fsStrikeOut]; end; procedure frReadMemo(Stream: TStream; l: TStrings); var s: String; b: Byte; n: Word; begin l.Clear; Stream.Read(n, 2); if n > 0 then repeat Stream.Read(n, 2); SetLength(s, n); if n > 0 then Stream.Read(s[1], n); l.Add(s); Stream.Read(b, 1); until b = 0 else Stream.Read(b, 1); end; function frReadString(Stream: TStream): String; var s: String; n: Word; b: Byte; begin Stream.Read(n, 2); SetLength(s, n); if n > 0 then Stream.Read(s[1], n); Stream.Read(b, 1); Result := s; end; procedure frReadMemo22(Stream: TStream; l: TStrings); var s: String; i: Integer; b: Byte; begin SetLength(s, 4096); l.Clear; i := 1; repeat Stream.Read(b,1); if (b = 13) or (b = 0) then begin SetLength(s, i - 1); if not ((b = 0) and (i = 1)) then l.Add(s); SetLength(s, 4096); i := 1; end else if b <> 0 then begin s[i] := Chr(b); Inc(i); if i > 4096 then SetLength(s, Length(s) + 4096); end; until b = 0; end; function frReadString22(Stream: TStream): String; var s: String; i: Integer; b: Byte; begin SetLength(s, 4096); i := 1; repeat Stream.Read(b, 1); if b = 0 then SetLength(s, i - 1) else begin s[i] := Chr(b); Inc(i); if i > 4096 then SetLength(s, Length(s) + 4096); end; until b = 0; Result := s; end; function frReadBoolean(Stream: TStream): Boolean; begin Stream.Read(Result, 1); end; function frReadByte(Stream: TStream): Byte; begin Stream.Read(Result, 1); end; function frReadWord(Stream: TStream): Word; begin Stream.Read(Result, 2); end; function frReadInteger(Stream: TStream): Integer; begin Stream.Read(Result, 4); end; procedure frReadFont(Stream: TStream; Font: TFont); var w: Word; begin Font.Name := frReadString(Stream); Font.Size := frReadInteger(Stream); Font.Style := frSetFontStyle(frReadWord(Stream)); Font.Color := frReadInteger(Stream); w := frReadWord(Stream); Font.Charset := w; end; function ReadString(Stream: TStream): String; begin if frVersion >= 23 then Result := frReadString(Stream) else Result := frReadString22(Stream); end; procedure ReadMemo(Stream: TStream; Memo: TStrings); begin if frVersion >= 23 then frReadMemo(Stream, Memo) else frReadMemo22(Stream, Memo); end; { --------------------------- utils -------------------------------- } function frFindComponent(Owner: TComponent; Name: String): TComponent; var n: Integer; s1, s2: String; begin Result := nil; n := Pos('.', Name); try if n = 0 then Result := Owner.FindComponent(Name) else begin s1 := Copy(Name, 1, n - 1); // module name s2 := Copy(Name, n + 1, 255); // component name Owner := FindGlobalComponent(s1); if Owner <> nil then begin n := Pos('.', s2); if n <> 0 then // frame name - Delphi5 begin s1 := Copy(s2, 1, n - 1); s2 := Copy(s2, n + 1, 255); Owner := Owner.FindComponent(s1); if Owner <> nil then Result := Owner.FindComponent(s2); end else Result := Owner.FindComponent(s2); end; end; except on Exception do raise EClassNotFound.Create('Missing ' + Name); end; end; function frRemoveQuotes(const s: String): String; begin if (Length(s) > 2) and (s[1] = '"') and (s[Length(s)] = '"') then Result := Copy(s, 2, Length(s) - 2) else Result := s; end; function frRemoveQuotes1(const s: String): String; begin if (Length(s) > 2) and (s[1] = '''') and (s[Length(s)] = '''') then Result := Copy(s, 2, Length(s) - 2) else Result := s; end; procedure frGetFieldNames(DataSet: TDataSet; List: TStrings); begin try DataSet.GetFieldNames(List); except; end; end; procedure frGetDataSetAndField(ComplexName: String; var DataSet: TDataSet; var Field: String); var i, j, n: Integer; f: TComponent; sl: TStringList; s: String; c: Char; cn: TControl; function FindField(ds: TDataSet; FName: String): String; var sl: TStringList; begin Result := ''; if ds <> nil then begin sl := TStringList.Create; frGetFieldNames(ds, sl); if sl.IndexOf(FName) <> -1 then Result := FName; sl.Free; end; end; begin Field := ''; f := Report.Owner; sl := TStringList.Create; n := 0; j := 1; for i := 1 to Length(ComplexName) do begin c := ComplexName[i]; if c = '"' then begin sl.Add(Copy(ComplexName, i, 255)); j := i; break; end else if c = '.' then begin sl.Add(Copy(ComplexName, j, i - j)); j := i + 1; Inc(n); end; end; if j <> i then sl.Add(Copy(ComplexName, j, 255)); case n of 0: // field name only begin if DataSet <> nil then begin s := frRemoveQuotes(ComplexName); Field := FindField(DataSet, s); end; end; 1: // DatasetName.FieldName begin if sl.Count > 1 then begin DataSet := TDataSet(frFindComponent(f, sl[0])); s := frRemoveQuotes(sl[1]); Field := FindField(DataSet, s); end; end; 2: // FormName.DatasetName.FieldName begin f := FindGlobalComponent(sl[0]); if f <> nil then begin DataSet := TDataSet(f.FindComponent(sl[1])); s := frRemoveQuotes(sl[2]); Field := FindField(DataSet, s); end; end; 3: // FormName.FrameName.DatasetName.FieldName - Delphi5 begin f := FindGlobalComponent(sl[0]); if f <> nil then begin cn := TControl(f.FindComponent(sl[1])); DataSet := TDataSet(cn.FindComponent(sl[2])); s := frRemoveQuotes(sl[3]); Field := FindField(DataSet, s); end; end; end; sl.Free; end; function frGetFieldValue(F: TField): Variant; begin if not F.DataSet.Active then F.DataSet.Open; if Assigned(F.OnGetText) then Result := F.DisplayText else if F.DataType in [ftLargeint] then Result := F.DisplayText else Result := F.AsVariant; if Result = Null then if F.DataType = ftString then Result := '' else if F.DataType = ftWideString then Result := '' else if F.DataType = ftBoolean then Result := False else Result := 0; end; function FindTfrxDataset(ds: TDataset): TfrxDataset; var i: Integer; sl: TStringList; ds1: TfrxDataset; begin Result := nil; sl := TStringList.Create; frxGetDatasetList(sl); for i := 0 to sl.Count - 1 do begin ds1 := TfrxDataset(sl.Objects[i]); if (ds1 is TfrxDBDataset) and (TfrxDBDataset(ds1).GetDataSet = ds) then begin Result := ds1; break; end; end; sl.Free; end; function GetBrackedVariable(const s: String; var i, j: Integer): String; var c: Integer; fl1, fl2: Boolean; begin j := i; fl1 := True; fl2 := True; c := 0; Result := ''; if (s = '') or (j > Length(s)) then Exit; Dec(j); repeat Inc(j); if fl1 and fl2 then if s[j] = '[' then begin if c = 0 then i := j; Inc(c); end else if s[j] = ']' then Dec(c); if fl1 then if s[j] = '"' then fl2 := not fl2; if fl2 then if s[j] = '''' then fl1 := not fl1; until (c = 0) or (j >= Length(s)); Result := Copy(s, i + 1, j - i - 1); end; function Substitute(const ParName: String): String; begin Result := ParName; if CompareText(ParName, frRepInfo[0]) = 0 then Result := 'Report.ReportOptions.Description' else if CompareText(ParName, frRepInfo[1]) = 0 then Result := 'Report.ReportOptions.Name' else if CompareText(ParName, frRepInfo[2]) = 0 then Result := 'Report.ReportOptions.Author' else if CompareText(ParName, frRepInfo[3]) = 0 then Result := 'Report.ReportOptions.VersionMajor' else if CompareText(ParName, frRepInfo[4]) = 0 then Result := 'Report.ReportOptions.VersionMinor' else if CompareText(ParName, frRepInfo[5]) = 0 then Result := 'Report.ReportOptions.VersionRelease' else if CompareText(ParName, frRepInfo[6]) = 0 then Result := 'Report.ReportOptions.VersionBuild' else if CompareText(ParName, frRepInfo[7]) = 0 then Result := 'Report.ReportOptions.CreateDate' else if CompareText(ParName, frRepInfo[8]) = 0 then Result := 'Report.ReportOptions.LastChange' else if CompareText(ParName, 'CURY') = 0 then Result := 'Engine.CurY' else if CompareText(ParName, 'FREESPACE') = 0 then Result := 'Engine.FreeSpace' else if CompareText(ParName, 'FINALPASS') = 0 then Result := 'Engine.FinalPass' else if CompareText(ParName, 'PAGEHEIGHT') = 0 then Result := 'Engine.PageHeight' else if CompareText(ParName, 'PAGEWIDTH') = 0 then Result := 'Engine.PageWidth' end; procedure DoExpression(const Expr: String; var Value: String); begin Value := Substitute(Expr); if ConvertDatasetAndField(Expr) <> Expr then Value := ConvertDatasetAndField(Expr); end; procedure ExpandVariables(var s: String); var i, j: Integer; s1, s2: String; begin i := 1; repeat while (i < Length(s)) and (s[i] <> '[') do Inc(i); s1 := GetBrackedVariable(s, i, j); if i <> j then begin Delete(s, i, j - i + 1); s2 := s1; DoExpression(s1, s2); s2 := '[' + s2 + ']'; Insert(s2, s, i); Inc(i, Length(s2)); j := 0; end; until i = j; end; procedure ExpandVariables1(var s: String); var i, j: Integer; s1, s2: String; begin i := 1; repeat while (i < Length(s)) and (s[i] <> '[') do Inc(i); s1 := GetBrackedVariable(s, i, j); if i <> j then begin Delete(s, i, j - i + 1); s2 := s1; DoExpression(s1, s2); Insert(s2, s, i); Inc(i, Length(s2)); j := 0; end; until i = j; end; procedure ConvertMemoExpressions(m: TfrxCustomMemoView; s: String); begin ExpandVariables(s); m.Memo.Text := AnsiToUnicode(s, m.Font.Charset); end; { --------------------------- report items -------------------------------- } var Name: String; HVersion, LVersion: Byte; x, y, dx, dy: Integer; Flags: Word; FrameTyp: Word; FrameWidth: Single; FrameColor: TColor; FrameStyle: Word; FillColor: TColor; Format: Integer; FormatStr: String; Visible: WordBool; gapx, gapy: Integer; Restrictions: Word; Tag: String; Memo, Script: TStringList; BandAlign: Byte; NeedCreateName: Boolean; procedure AddScript(c: TfrxComponent; const ScriptName: String); var i: Integer; vName: String; begin vName := c.Name; if Script.Count <> 0 then begin Report.ScriptText.Add('procedure ' + vName + scriptName); Report.ScriptText.Add('begin'); Report.ScriptText.Add(' with ' + vName + ', Engine do'); Report.ScriptText.Add(' begin'); if Script[0] <> 'begin' then Report.ScriptText.Add(Script[0]); for i := 1 to Script.Count - 2 do Report.ScriptText.Add(Script[i]); if Script[0] <> 'begin' then begin if Script.Count <> 1 then Report.ScriptText.Add(Script[Script.Count - 1]); Report.ScriptText.Add(' end'); Report.ScriptText.Add('end;'); end else begin Report.ScriptText.Add(' end'); Report.ScriptText.Add(Script[Script.Count - 1] + ';'); end; Report.ScriptText.Add(''); if c is TfrxDialogPage then TfrxDialogPage(c).OnShow := vName + 'OnShow' else if c is TfrxDialogControl then TfrxDialogControl(c).OnClick := vName + 'OnClick' else if c is TfrxReportComponent then TfrxReportComponent(c).OnBeforePrint := vName + 'OnBeforePrint'; end; end; procedure SetfrxComponent(c: TfrxComponent); procedure SetValidIdent(var Ident: string); const Alpha = ['A'..'Z', 'a'..'z', '_']; AlphaNumeric = Alpha + ['0'..'9']; var I: Integer; begin if (Length(Ident) > 0) and not (Ident[1] in Alpha) then Ident[1] := '_'; for I := 2 to Length(Ident) do if not (Ident[I] in AlphaNumeric) then Ident[I] := '_'; end; begin SetValidIdent(Name); c.Name := Name; if NeedCreateName then c.CreateUniqueName; c.Left := x + offsx; c.Top := y + offsy; c.Width := dx; c.Height := dy; c.Visible := Visible; end; procedure SetfrxView(c: TfrxView); begin if (FrameTyp and frftRight) <> 0 then c.Frame.Typ := c.Frame.Typ + [ftRight]; if (FrameTyp and frftBottom) <> 0 then c.Frame.Typ := c.Frame.Typ + [ftBottom]; if (FrameTyp and frftLeft) <> 0 then c.Frame.Typ := c.Frame.Typ + [ftLeft]; if (FrameTyp and frftTop) <> 0 then c.Frame.Typ := c.Frame.Typ + [ftTop]; c.Frame.Width := FrameWidth; c.Frame.Color := FrameColor; c.Frame.Style := TfrxFrameStyle(FrameStyle); c.Color := FillColor; if BandAlign = 6 then BandAlign := 0; if BandAlign = 7 then BandAlign := 6; c.Align := TfrxAlign(BandAlign); c.TagStr := Tag; AddScript(c, 'OnBeforePrint(Sender: TfrxComponent);'); end; procedure TfrViewLoadFromStream; var w: Integer; begin with Stream do begin NeedCreateName := False; if frVersion >= 23 then Name := ReadString(Stream) else NeedCreateName := True; if frVersion > 23 then begin Read(HVersion, 1); Read(LVersion, 1); end; Read(x, 4); Read(y, 4); Read(dx, 4); Read(dy, 4); Read(Flags, 2); Read(FrameTyp, 2); Read(FrameWidth, 4); Read(FrameColor, 4); Read(FrameStyle, 2); Read(FillColor, 4); Read(Format, 4); FormatStr := ReadString(Stream); ReadMemo(Stream, Memo); if frVersion >= 23 then begin ReadMemo(Stream, Script); Read(Visible, 2); end; if frVersion >= 24 then begin Read(Restrictions, 2); Tag := ReadString(Stream); Read(gapx, 4); Read(gapy, 4); end; w := PInteger(@FrameWidth)^; if w <= 10 then w := w * 1000; if HVersion > 1 then Read(BandAlign, 1); FrameWidth := w / 1000; end; end; procedure TfrMemoViewLoadFromStream; var w: Word; i: Integer; Alignment: Integer; Highlight: TfrHighlightAttr; HighlightStr: String; LineSpacing, CharacterSpacing: Integer; m: TfrxMemoView; procedure DecodeDisplayFormat; var LCategory: Byte; LType: Byte; LNoOfDecimals: Byte; LSeparator: Char; begin LCategory := (Format and $0F000000) shr 24; LType := (Format and $00FF0000) shr 16; LNoOfDecimals := (Format and $0000FF00) shr 8; LSeparator := Chr(Format and $000000FF); case LCategory of 0: { text } m.DisplayFormat.Kind := fkText; 1: { number } begin m.DisplayFormat.Kind := fkNumeric; m.DisplayFormat.DecimalSeparator := LSeparator; case LType of 0: m.DisplayFormat.FormatStr := '%2.' + IntToStr(LNoOfDecimals) + 'g'; 1: m.DisplayFormat.FormatStr := '%g'; 2: m.DisplayFormat.FormatStr := '%2.' + IntToStr(LNoOfDecimals) + 'f'; 3: m.DisplayFormat.FormatStr := '%2.' + IntToStr(LNoOfDecimals) + 'n'; else m.DisplayFormat.FormatStr := '%g' { can't convert custom format string }; end; end; 2: { date } begin m.DisplayFormat.Kind := fkDateTime; case LType of 0: m.DisplayFormat.FormatStr := 'dd.mm.yy'; 1: m.DisplayFormat.FormatStr := 'dd.mm.yyyy'; 2: m.DisplayFormat.FormatStr := 'd mmm yyyy'; 3: m.DisplayFormat.FormatStr := LongDateFormat; 4: m.DisplayFormat.FormatStr := FormatStr; end; end; 3: { time } begin m.DisplayFormat.Kind := fkDateTime; case LType of 0: m.DisplayFormat.FormatStr := 'hh:nn:ss'; 1: m.DisplayFormat.FormatStr := 'h:nn:ss'; 2: m.DisplayFormat.FormatStr := 'hh:nn'; 3: m.DisplayFormat.FormatStr := 'h:nn'; 4: m.DisplayFormat.FormatStr := FormatStr; end; end; 4: { boolean } begin m.DisplayFormat.Kind := fkBoolean; case LType of 0: m.DisplayFormat.FormatStr := '0,1'; 1: m.DisplayFormat.FormatStr := 'Нет,Да'; 2: m.DisplayFormat.FormatStr := '_,X'; 3: m.DisplayFormat.FormatStr := 'False,True'; 4: m.DisplayFormat.FormatStr := FormatStr; end; end; end; end; begin TfrViewLoadFromStream; m := TfrxMemoView.Create(Page); SetfrxComponent(m); SetfrxView(m); with Stream do begin { font info } m.Font.Name := ReadString(Stream); Read(i, 4); m.Font.Size := i; Read(w, 2); m.Font.Style := frSetFontStyle(w); Read(i, 4); m.Font.Color := i; { text align, rotation } Read(Alignment, 4); if (Alignment and frtaRight) <> 0 then m.HAlign := haRight; if (Alignment and frtaCenter) <> 0 then m.HAlign := haCenter; if (Alignment and 3) = 3 then m.HAlign := haBlock; if (Alignment and frtaVertical) <> 0 then m.Rotation := 90; if (Alignment and frtaMiddle) <> 0 then m.VAlign := vaCenter; if (Alignment and frtaDown) <> 0 then m.VAlign := vaBottom; { charset } Read(w, 2); if frVersion < 23 then w := DEFAULT_CHARSET; m.Font.Charset := w; Read(Highlight, 10); HighlightStr := ReadString(Stream); m.Highlight.Condition := HighlightStr; m.Highlight.Color := Highlight.FillColor; m.Highlight.Font.Color := Highlight.FontColor; m.Highlight.Font.Style := frSetFontStyle(Highlight.FontStyle); if frVersion >= 24 then begin Read(LineSpacing, 4); m.LineSpacing := LineSpacing; Read(CharacterSpacing, 4); m.CharSpacing := CharacterSpacing; end; end; if frVersion = 21 then Flags := Flags or flWordWrap; if (Flags and flStretched) <> 0 then m.StretchMode := smMaxHeight; m.WordWrap := (Flags and flWordWrap) <> 0; m.WordBreak := (Flags and flWordBreak) <> 0; m.AutoWidth := (Flags and flAutoSize) <> 0; m.AllowExpressions := (Flags and flTextOnly) = 0; m.SuppressRepeated := (Flags and flSuppressRepeated) <> 0; m.HideZeros := (Flags and flHideZeros) <> 0; m.Underlines := (Flags and flUnderlines) <> 0; m.RTLReading := (Flags and flRTLReading) <> 0; DecodeDisplayFormat; ConvertMemoExpressions(m, Memo.Text); end; procedure TfrPictureViewLoadFromStream; var b, BlobType: Byte; n: Integer; Graphic: TGraphic; TempStream: TMemoryStream; p: TfrxPictureView; begin TfrViewLoadFromStream; p := TfrxPictureView.Create(Page); SetfrxComponent(p); SetfrxView(p); Stream.Read(b, 1); if HVersion * 10 + LVersion > 10 then Stream.Read(BlobType, 1); Stream.Read(n, 4); Graphic := nil; case b of pkBitmap: Graphic := TBitmap.Create; pkMetafile: Graphic := TMetafile.Create; pkIcon: Graphic := TIcon.Create; pkJPEG: Graphic := TJPEGImage.Create; end; p.Picture.Graphic := Graphic; if Graphic <> nil then begin Graphic.Free; TempStream := TMemoryStream.Create; TempStream.CopyFrom(Stream, n - Stream.Position); TempStream.Position := 0; p.Picture.Graphic.LoadFromStream(TempStream); TempStream.Free; end; Stream.Seek(n, soFromBeginning); p.Stretched := (Flags and flStretched) <> 0; p.Center := (Flags and flPictCenter) <> 0; p.KeepAspectRatio := (Flags and flPictRatio) <> 0; if Memo.Count > 0 then p.DataField := Memo[0]; end; procedure TfrBandViewLoadFromStream; var ChildBand, Master: String; Columns: Integer; ColumnWidth: Integer; ColumnGap: Integer; NewColumnAfter: Integer; BandType: TfrBandType; Band: TfrxBand; begin TfrViewLoadFromStream; BandType := TfrBandType(FrameTyp); Band := TfrxBand(Bands[BandType].NewInstance); Band.Create(Page); if BandType in [btCrossHeader..btCrossFooter] then Band.Vertical := True; SetfrxComponent(Band); AddScript(Band, 'OnBeforePrint(Sender: TfrxComponent);'); if frVersion > 23 then begin ChildBand := frReadString(Stream); if ChildBand <> '' then AddFixup(Band, 'Child', ChildBand); Stream.Read(Columns, 4); Stream.Read(ColumnWidth, 4); Stream.Read(ColumnGap, 4); { not implemented } Stream.Read(NewColumnAfter, 4); { not implemented } if HVersion * 10 + LVersion > 20 then Master := frReadString(Stream); if Band is TfrxDataBand then begin TfrxDataBand(Band).Columns := Columns; TfrxDataBand(Band).ColumnWidth := ColumnWidth; TfrxDataBand(Band).ColumnGap := ColumnGap; if (FormatStr <> '') and (FormatStr[1] in ['1'..'9']) then TfrxDataBand(Band).RowCount := StrToInt(FormatStr) else TfrxDataBand(Band).DatasetName := FormatStr; end; end; Band.Stretched := (Flags and flStretched) <> 0; Band.StartNewPage := (Flags and flBandNewPageAfter) <> 0; Band.PrintChildIfInvisible := (Flags and flBandPrintChildIfInvisible) <> 0; Band.AllowSplit := (Flags and flBandBreaked) <> 0; if Band is TfrxDataBand then TfrxDataBand(Band).PrintifDetailEmpty := (Flags and flBandPrintifSubsetEmpty) <> 0; if Band is TfrxPageHeader then TfrxPageHeader(Band).PrintOnFirstPage := (Flags and flBandOnFirstPage) <> 0; if Band is TfrxPageFooter then begin TfrxPageFooter(Band).PrintOnFirstPage := (Flags and flBandOnFirstPage) <> 0; TfrxPageFooter(Band).PrintOnLastPage := (Flags and flBandOnLastPage) <> 0; end; if Band is TfrxHeader then TfrxHeader(Band).ReprintOnNewPage := (Flags and flBandRepeatHeader) <> 0; if Band is TfrxGroupHeader then begin TfrxGroupHeader(Band).ReprintOnNewPage := (Flags and flBandRepeatHeader) <> 0; DoExpression(FormatStr, FormatStr); TfrxGroupHeader(Band).Condition := FormatStr; end; end; procedure TfrSubreportLoadFromStream; var s: TfrxSubreport; SubPage: Integer; begin TfrViewLoadFromStream; s := TfrxSubreport.Create(Page); SetfrxComponent(s); Stream.Read(SubPage, 4); s.Page := TfrxReportPage(Report.Pages[SubPage]); with s.Page do begin if Name = '' then CreateUniqueName; LeftMargin := 0; RightMargin := 0; TopMargin := 0; BottomMargin := 0; end; end; procedure TfrLineViewLoadFromStream; var Line: TfrxLineView; begin TfrViewLoadFromStream; Line := TfrxLineView.Create(Page); SetfrxComponent(Line); SetfrxView(Line); if (Flags and flStretched) <> 0 then Line.StretchMode := smMaxHeight; end; procedure ReadStdCtrl(c: TfrxDialogControl); begin TfrViewLoadFromStream; SetfrxComponent(c); THackControl(c.Control).Color := frReadInteger(Stream); c.Control.Enabled := frReadBoolean(Stream); frReadFont(Stream, c.Font); AddScript(c, 'OnClick(Sender: TfrxComponent);'); end; procedure ReadTfrLabelControl; var l: TfrxLabelControl; begin l := TfrxLabelControl.Create(Page); ReadStdCtrl(l); l.Alignment := TAlignment(frReadByte(Stream)); l.AutoSize := frReadBoolean(Stream); l.Caption := frReadString(Stream); l.WordWrap := frReadBoolean(Stream); end; procedure ReadTfrEditControl; var e: TfrxEditControl; begin e := TfrxEditControl.Create(Page); ReadStdCtrl(e); e.Text := frReadString(Stream); e.ReadOnly := frReadBoolean(Stream); end; procedure ReadTfrMemoControl; var m: TfrxMemoControl; begin m := TfrxMemoControl.Create(Page); ReadStdCtrl(m); m.Text := frReadString(Stream); m.ReadOnly := frReadBoolean(Stream); end; procedure ReadTfrButtonControl; var b: TfrxButtonControl; begin b := TfrxButtonControl.Create(Page); ReadStdCtrl(b); b.Caption := frReadString(Stream); b.ModalResult := frReadWord(Stream); b.Cancel := b.ModalResult = mrCancel; b.Default := b.ModalResult = mrOk; end; procedure ReadTfrCheckBoxControl; var b: TfrxCheckBoxControl; begin b := TfrxCheckBoxControl.Create(Page); ReadStdCtrl(b); b.Alignment := TAlignment(frReadByte(Stream)); b.Checked := frReadBoolean(Stream); b.Caption := frReadString(Stream); end; procedure ReadTfrRadioButtonControl; var b: TfrxRadioButtonControl; begin b := TfrxRadioButtonControl.Create(Page); ReadStdCtrl(b); b.Alignment := TAlignment(frReadByte(Stream)); b.Checked := frReadBoolean(Stream); b.Caption := frReadString(Stream); end; procedure ReadTfrListBoxControl; var b: TfrxListBoxControl; begin b := TfrxListBoxControl.Create(Page); ReadStdCtrl(b); frReadMemo(Stream, b.Items); end; procedure ReadTfrComboBoxControl; var c: TfrxComboBoxControl; b: Byte; begin c := TfrxComboBoxControl.Create(Page); ReadStdCtrl(c); frReadMemo(Stream, c.Items); if HVersion * 10 + LVersion > 10 then begin b := frReadByte(Stream); if (HVersion * 10 + LVersion <= 20) and (b > 0) then Inc(b); c.Style := TComboBoxStyle(b); end; end; procedure ReadTfrDateEditControl; var b: TfrxDateEditControl; begin b := TfrxDateEditControl.Create(Page); ReadStdCtrl(b); b.DateFormat := TDTDateFormat(frReadByte(Stream)); end; procedure ReadTfrBarcodeView; var v: TfrxBarcodeView; Param: TfrBarcodeRec; begin v := TfrxBarcodeView.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); SetfrxView(v); Stream.Read(Param, SizeOf(Param)); if Param.cModul = 1 then begin Param.cRatio := Param.cRatio / 2; Param.cModul := 2; end; if (Memo.Count > 0) and (Memo[0][1] <> '[') then v.Text := Memo[0] else v.Expression := Memo[0]; v.Rotation := Round(Param.cAngle); v.CalcChecksum := Param.cCheckSum; v.BarType := Param.cBarType; v.Zoom := Param.cRatio; v.ShowText := Param.cShowText; end; procedure ReadTfrChartView; var v: TfrxChartView; b: Byte; ChartOptions: TChartOptions; LegendObj, ValueObj, Top10Label: String; Ser: TChartSeries; dser: TfrxSeriesItem; begin v := TfrxChartView.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); SetfrxView(v); Stream.Read(b, 1); if b <> 1 then with Stream do begin Read(ChartOptions, SizeOf(ChartOptions)); LegendObj := frReadString(Stream); ValueObj := frReadString(Stream); Top10Label := frReadString(Stream); end; v.Chart.Frame.Visible := False; v.Chart.LeftWall.Brush.Style := bsClear; v.Chart.BottomWall.Brush.Style := bsClear; v.Chart.View3D := ChartOptions.Dim3D; v.Chart.Legend.Visible := ChartOptions.ShowLegend; v.Chart.AxisVisible := ChartOptions.ShowAxis; v.Chart.View3DWalls := ChartOptions.ChartType <> 5; v.Chart.BackWall.Brush.Style := bsClear; v.Chart.View3DOptions.Elevation := 315; v.Chart.View3DOptions.Rotation := 360; v.Chart.View3DOptions.Orthogonal := ChartOptions.ChartType <> 5; Ser := ChartTypes[ChartOptions.ChartType].Create(v.Chart); v.Chart.AddSeries(Ser); if ChartOptions.Colored then Ser.ColorEachPoint := True; Ser.Marks.Visible := ChartOptions.ShowMarks; Ser.Marks.Style := TSeriesMarksStyle(ChartOptions.MarksStyle); dser := v.SeriesData.Add; dser.DataType := dtBandData; dser.XSource := LegendObj; dser.YSource := ValueObj; dser.TopN := ChartOptions.Top10Num; dser.TopNCaption := Top10Label; end; procedure ReadTfrCheckBoxView; var v: TfrxCheckBoxView; CheckStyle: Byte; CheckColor: TColor; begin v := TfrxCheckBoxView.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); SetfrxView(v); if frVersion > 23 then begin Stream.Read(CheckStyle, 1); v.CheckStyle := TfrxCheckStyle(CheckStyle); Stream.Read(CheckColor, 4); v.CheckColor := CheckColor; end; if Memo.Count > 0 then v.Expression := Memo[0]; end; procedure ReadTfrOLEView; var v: TfrxOLEView; b: Byte; begin v := TfrxOLEView.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); SetfrxView(v); Stream.Read(b, 1); if b <> 0 then v.OleContainer.LoadFromStream(Stream); if Memo.Count > 0 then v.DataField := Memo[0]; end; procedure ReadTfrRichView; var v: TfrxRichView; b: Byte; n: Integer; begin v := TfrxRichView.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); SetfrxView(v); if (Flags and flStretched) <> 0 then v.StretchMode := smMaxHeight; Stream.Read(b, 1); Stream.Read(n, 4); if b <> 0 then v.RichEdit.Lines.LoadFromStream(Stream); Stream.Seek(n, soFromBeginning); if Memo.Count > 0 then v.DataField := Memo[0]; end; procedure ReadTfrShapeView; var v: TfrxShapeView; ShapeType: Byte; begin v := TfrxShapeView.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); SetfrxView(v); Stream.Read(ShapeType, 1); v.Shape := TfrxShapeKind(ShapeType); end; procedure ReadTfrRoundRectView; var v: TfrxShapeView; Cadre: TfrRoundRect; begin v := TfrxShapeView.Create(Page); v.Shape := skRoundRectangle; TfrViewLoadFromStream; SetfrxComponent(v); SetfrxView(v); Stream.Read(Cadre, SizeOf(Cadre)); end; procedure ReadTfrCrossView; var v: TfrxDBCrossView; sl: TStringList; s: String; i: Integer; function PureName1(const s: String): String; begin if Pos('+', s) <> 0 then Result := Copy(s, 1, Pos('+', s) - 1) else Result := s; end; function HasTotal(s: String): Boolean; begin Result := Pos('+', s) <> 0; end; function FuncName(s: String): String; begin if HasTotal(s) then begin Result := LowerCase(Copy(s, Pos('+', s) + 1, 255)); if Result = '' then Result := 'sum'; end else Result := ''; end; begin v := TfrxDBCrossView.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); SetfrxView(v); v.Border := frReadBoolean(Stream); v.RepeatHeaders := frReadBoolean(Stream); v.GapY := 1; v.Visible := True; { show header, not used } frReadBoolean(Stream); if LVersion > 0 then begin v.ShowColumnTotal := frReadBoolean(Stream); v.ShowRowTotal := v.ShowColumnTotal; v.MaxWidth := frReadInteger(Stream); {FHeaderWidth := }frReadInteger(Stream); end; if LVersion > 1 then begin {FDictionary.Text := }frReadString(Stream); {FMaxNameLen := }frReadInteger(Stream); end; if LVersion > 2 then {FDataCaption := }frReadString(Stream); sl := TStringList.Create; if Memo.Count >= 4 then begin v.DataSetName := Memo[0]; frxSetCommaText(Memo[1], sl); v.RowLevels := sl.Count; v.RowFields.Clear; for i := 0 to sl.Count - 1 do begin s := PureName1(sl[i]); {row field name } v.RowFields.Add(s); v.RowTotalMemos[i + 1].Visible := s <> sl[i]; end; frxSetCommaText(Memo[2], sl); v.ColumnLevels := sl.Count; v.ColumnFields.Clear; for i := 0 to sl.Count - 1 do begin s := PureName1(sl[i]); {column field name } v.ColumnFields.Add(s); v.ColumnTotalMemos[i + 1].Visible := s <> sl[i]; end; frxSetCommaText(Memo[3], sl); v.CellLevels := sl.Count; v.CellFields.Clear; for i := 0 to sl.Count - 1 do begin s := PureName1(sl[i]); {column field name } v.CellFields.Add(s); s := FuncName(sl[i]); if s = 'sum' then v.CellFunctions[i] := cfSum else if s = 'avg' then v.CellFunctions[i] := cfAvg else if s = 'min' then v.CellFunctions[i] := cfMin else if s = 'max' then v.CellFunctions[i] := cfMax else if s = 'count' then v.CellFunctions[i] := cfCount end; end; sl.Free; end; {------------------------- datacontrols --------------------------------------} procedure ReadTfrBDEDatabase; var v: TfrxBDEDatabase; s: String; begin v := TfrxBDEDatabase.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); v.DatabaseName := frReadString(Stream); s := frReadString(Stream); if s <> '' then v.AliasName := s; s := frReadString(Stream); if s <> '' then v.DriverName := s; v.LoginPrompt := frReadBoolean(Stream); frReadMemo(Stream, v.Params); v.Connected := frReadBoolean(Stream); end; { field list is not stored in FR3, just skip } procedure TfrXXXDataSetReadFields; var i: Integer; n: Word; fLookup: Boolean; b: Byte; begin Stream.Read(n, 2); // FieldCount for i := 0 to n - 1 do begin // Old version of BDEComponents stores fieldlist wrongfully if HVersion * 10 + LVersion <= 10 then begin b := frReadByte(Stream); // islookup frReadString(Stream); // fieldname if b = 1 then begin frReadByte(Stream); // datatype frReadWord(Stream); // size frReadString(Stream); // KeyFields frReadString(Stream); // LookupDataset frReadString(Stream); // LookupKeyFields frReadString(Stream); // LookupResultField end; continue; end; frReadByte(Stream); // DataType frReadString(Stream); // FieldName fLookup := frReadBoolean(Stream); // Lookup frReadWord(Stream); // Size if fLookup then begin frReadString(Stream); // KeyFields frReadString(Stream); // LookupDataset frReadString(Stream); // LookupKeyFields frReadString(Stream); // LookupResultField end; end; end; procedure ReadTfrBDETable; var v: TfrxBDETable; begin v := TfrxBDETable.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); v.SetBounds(-1000, -1000, 0, 0); v.DatabaseName := frReadString(Stream); v.Filter := frReadString(Stream); v.Filtered := Trim(v.Filter) <> ''; v.IndexName := frReadString(Stream); v.MasterFields := frReadString(Stream); AddFixup(v, 'Master', frReadString(Stream)); v.TableName := frReadString(Stream); frReadBoolean(Stream); // active TfrXXXDataSetReadFields; Report.Datasets.Add(v); end; procedure TfrXXXQueryReadParams(Query: TfrxCustomQuery); var i: Integer; w, n: Word; begin Stream.Read(n, 2); for i := 0 to n - 1 do with Query.Params[i] do begin Stream.Read(w, 2); DataType := ParamTypes[w]; Stream.Read(w, 2); Expression := frReadString(Stream); end; end; procedure ReadTfrBDEQuery; var v: TfrxBDEQuery; begin v := TfrxBDEQuery.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); v.SetBounds(-1000, -1000, 0, 0); v.DatabaseName := frReadString(Stream); v.Filter := frReadString(Stream); v.Filtered := Trim(v.Filter) <> ''; AddFixup(v, 'Master', frReadString(Stream)); frReadMemo(Stream, v.SQL); frReadBoolean(Stream); TfrXXXDataSetReadFields; TfrXXXQueryReadParams(v); v.IsLoading := True; v.UpdateParams; v.IsLoading := False; end; procedure ReadTfrADODatabase; var v: TfrxADODatabase; begin v := TfrxADODatabase.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); v.DatabaseName := frReadString(Stream); v.LoginPrompt := frReadBoolean(Stream); v.Connected := frReadBoolean(Stream); end; procedure ReadTfrADOTable; var v: TfrxADOTable; begin v := TfrxADOTable.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); v.SetBounds(-1000, -1000, 0, 0); AddFixup(v, 'Database', frReadString(Stream)); v.Filter := frReadString(Stream); v.Filtered := Trim(v.Filter) <> ''; v.IndexName := frReadString(Stream); v.MasterFields := frReadString(Stream); AddFixup(v, 'Master', frReadString(Stream)); v.TableName := frReadString(Stream); frReadBoolean(Stream); // active if LVersion >= 2 then frReadBoolean(Stream); // enableBCD TfrXXXDataSetReadFields; Report.Datasets.Add(v); end; procedure ReadTfrADOQuery; var v: TfrxADOQuery; begin v := TfrxADOQuery.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); v.SetBounds(-1000, -1000, 0, 0); AddFixup(v, 'Database', frReadString(Stream)); v.Filter := frReadString(Stream); v.Filtered := Trim(v.Filter) <> ''; AddFixup(v, 'Master', frReadString(Stream)); frReadMemo(Stream, v.SQL); frReadBoolean(Stream); // active if LVersion >= 2 then frReadBoolean(Stream); // enableBCD TfrXXXDataSetReadFields; TfrXXXQueryReadParams(v); v.IsLoading := True; v.UpdateParams; v.IsLoading := False; end; procedure ReadTfrIBXDatabase; var v: TfrxIBXDatabase; begin v := TfrxIBXDatabase.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); v.DatabaseName := frReadString(Stream); v.LoginPrompt := frReadBoolean(Stream); if HVersion * 10 + LVersion > 20 then v.SQLDialect := frReadInteger(Stream); frReadMemo(Stream, v.Params); v.Connected := frReadBoolean(Stream); end; procedure ReadTfrIBXTable; var v: TfrxIBXTable; begin v := TfrxIBXTable.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); v.SetBounds(-1000, -1000, 0, 0); AddFixup(v, 'Database', frReadString(Stream)); v.TableName := frReadString(Stream); v.Filter := frReadString(Stream); v.Filtered := Trim(v.Filter) <> ''; v.IndexName := frReadString(Stream); v.IndexFieldNames := frReadString(Stream); v.MasterFields := frReadString(Stream); AddFixup(v, 'Master', frReadString(Stream)); frReadBoolean(Stream); // active TfrXXXDataSetReadFields; Report.Datasets.Add(v); end; procedure ReadTfrIBXQuery; var v: TfrxIBXQuery; begin v := TfrxIBXQuery.Create(Page); TfrViewLoadFromStream; SetfrxComponent(v); v.SetBounds(-1000, -1000, 0, 0); AddFixup(v, 'Database', frReadString(Stream)); v.Filter := frReadString(Stream); v.Filtered := Trim(v.Filter) <> ''; AddFixup(v, 'Master', frReadString(Stream)); frReadMemo(Stream, v.SQL); frReadBoolean(Stream); // active TfrXXXDataSetReadFields; TfrXXXQueryReadParams(v); v.IsLoading := True; v.UpdateParams; v.IsLoading := False; end; {----------------------------------------------------------------------------} procedure TfrDictionaryLoadFromStream; var w: Word; NewVersion: Boolean; Variables, FieldAliases, BandDatasources: TfrxVariables; SMemo: TStringList; procedure LoadFRVariables(Value: TfrxVariables); var i, n: Integer; s: String; begin Stream.Read(n, 4); for i := 0 to n - 1 do begin s := frReadString(Stream); Value[s] := frReadString(Stream); end; end; procedure LoadOldVariables; var i, n, d: Integer; b: Byte; s, s1, s2: String; function ReadStr: String; var n: Byte; begin Stream.Read(n, 1); SetLength(Result, n); Stream.Read(Result[1], n); end; begin with Stream do begin ReadBuffer(n, SizeOf(n)); for i := 0 to n - 1 do begin Read(b, 1); // typ Read(d, 4); // otherkind s1 := ReadStr; // dataset s2 := ReadStr; // field s := ReadStr; // var name if b = 2 then // it's system variable or expression if d = 1 then s1 := s2 else s1 := frSpecFuncs[d] else if b = 1 then // it's data field s1 := s1 + '."' + s2 + '"' else s1 := ''; FieldAliases[' ' + s] := s1; end; end; ReadMemo(Stream, SMemo); for i := 0 to SMemo.Count - 1 do begin s := SMemo[i]; if (s <> '') and (s[1] <> ' ') then Variables[s] := '' else Variables[s] := FieldAliases[s]; end; FieldAliases.Clear; end; procedure ConvertToNewFormat; var i: Integer; s: String; begin for i := 0 to Variables.Count - 1 do begin s := Variables.Items[i].Name; if s <> '' then if s[1] = ' ' then s := Copy(s, 2, 255) else s := ' ' + s; Variables.Items[i].Name := s; end; end; begin Variables := TfrxVariables.Create; FieldAliases := TfrxVariables.Create; BandDatasources := TfrxVariables.Create; SMemo := TStringList.Create; w := frReadWord(Stream); NewVersion := (w = $FFFF) or (w = $FFFE); if NewVersion then begin LoadFRVariables(Variables); LoadFRVariables(FieldAliases); LoadFRVariables(BandDatasources); end else begin Stream.Seek(-2, soFromCurrent); LoadOldVariables; end; if (Variables.Count > 0) and (Variables.Items[0].Name <> '') and (Variables.Items[0].Name[1] <> ' ') then ConvertToNewFormat; { if w = $FFFF then ConvertAliases;} Report.Variables.Assign(Variables); Variables.Free; FieldAliases.Free; BandDatasources.Free; SMemo.Free; end; procedure TfrPageLoadFromStream; var i: Integer; b: Byte; s: String[6]; pgSize, pgWidth, pgHeight: Integer; pgMargins: TRect; pgOr: TPrinterOrientation; pgBin: Integer; PrintToPrevPage, UseMargins: WordBool; ColCount, ColGap: Integer; PageType: TfrPageType; // dialog properties BorderStyle: Byte; Color: TColor; Left, Top, Width, Height: Integer; ReportPage: TfrxReportPage; DialogPage: TfrxDialogPage; ColWidth: Extended; begin ReportPage := TfrxReportPage.Create(nil); DialogPage := TfrxDialogPage.Create(nil); PageType := ptReport; with Stream do begin { paper size } Read(i, 4); if i = -1 then Read(pgSize, 4) else pgSize := i; ReportPage.PaperSize := pgSize; { width } Read(pgWidth, 4); { height } Read(pgHeight, 4); { margins } Read(pgMargins, Sizeof(pgMargins)); pgMargins.Left := pgMargins.Left * 5 div 18; pgMargins.Top := pgMargins.Top * 5 div 18; pgMargins.Right := pgMargins.Right * 5 div 18; pgMargins.Bottom := pgMargins.Bottom * 5 div 18; if (pgMargins.Left = 0) and (pgMargins.Top = 0) and (pgMargins.Right = 0) and (pgMargins.Bottom = 0) then begin pgMargins.Left := Round(frxPrinters.Printer.LeftMargin); pgMargins.Top := Round(frxPrinters.Printer.TopMargin); pgMargins.Right := Round(frxPrinters.Printer.RightMargin); pgMargins.Bottom := Round(frxPrinters.Printer.BottomMargin); end; ReportPage.LeftMargin := pgMargins.Left; ReportPage.TopMargin := pgMargins.Top; ReportPage.RightMargin := pgMargins.Right; ReportPage.BottomMargin := pgMargins.Bottom; { orientation } Read(b, 1); pgOr := TPrinterOrientation(b); ReportPage.Orientation := pgOr; ReportPage.PaperWidth := pgWidth / 10; ReportPage.PaperHeight := pgHeight / 10; if frVersion < 23 then Read(s[1], 6); { bin } pgBin := -1; if frVersion > 23 then Read(pgBin, 4); ReportPage.Bin := pgBin; ReportPage.BinOtherPages := pgBin; { print to prevpage } Read(PrintToPrevPage, 2); ReportPage.PrintOnPreviousPage := PrintToPrevPage; { not used } Read(UseMargins, 2); { columns } Read(ColCount, 4); ReportPage.Columns := ColCount; { not used } Read(ColGap, 4); if ColGap <> 0 then begin ColGap := Round(ColGap / 18 * 5); ReportPage.ColumnPositions.Clear; if ColCount > 0 then begin ColWidth := (ReportPage.PaperWidth - ReportPage.LeftMargin - ReportPage.RightMargin + ColGap) / ColCount; ReportPage.ColumnWidth := ColWidth - ColGap; while ReportPage.ColumnPositions.Count < ColCount do ReportPage.ColumnPositions.Add(FloatToStr(ReportPage.ColumnPositions.Count * ColWidth)); end; end; if frVersion > 23 then begin { page type } Read(PageType, 1); { name } ReportPage.Name := frReadString(Stream); DialogPage.Name := ReportPage.Name; { border style } Read(BorderStyle, 1); if BorderStyle = 0 then BorderStyle := Byte(bsDialog) else if BorderStyle = 1 then BorderStyle := Byte(bsSizeable); DialogPage.BorderStyle := TFormBorderStyle(BorderStyle); { caption } DialogPage.Caption := frReadString(Stream); { color } Read(Color, 4); DialogPage.Color := Color; { left-top-width-height } Read(Left, 4); Read(Top, 4); Read(Width, 4); Read(Height, 4); DialogPage.Left := Left; DialogPage.Top := Top; DialogPage.Width := Width; DialogPage.Height := Height; { position } Read(b, 1); if b <> 0 then b := Byte(poScreenCenter); DialogPage.Position := TPosition(b); if i = -1 then begin Script := TStringList.Create; frReadMemo(Stream, Script); end; end else ReportPage.CreateUniqueName; end; if PageType = ptReport then begin ReportPage.Parent := Report; DialogPage.Free; AddScript(ReportPage, 'OnBeforePrint(Sender: TfrxComponent);'); end else begin DialogPage.Parent := Report; ReportPage.Free; AddScript(DialogPage, 'OnShow(Sender: TfrxComponent);'); end; end; procedure ReadReportOptions; var l: Word; buf: String; ReportComment, ReportName, ReportAuthor : String; ReportCreateDate, ReportLastChange : TDateTime; ReportVersionMajor : String; ReportVersionMinor : String; ReportVersionRelease : String; ReportVersionBuild : String; ReportPasswordProtected : Boolean; ReportPassword : String; ReportGeneratorVersion : Byte; function HexChar1(Ch : Char) : Byte; begin Ch := UpCase(Ch); if (Ch <= '9') then Result := Ord(Ch) - Ord('0') else Result := Ord(Ch) - Ord('A') + 10; end; function HexToStr(const s : String) : String; var Len, i : Integer; Ch : Byte; NibbleH, NibbleL : Byte; begin Len := Length(s); SetLength(Result, Len shr 1); for i := 1 to Len shr 1 do begin NibbleH := HexChar1(s[i shl 1 - 1]); NibbleL := HexChar1(s[i shl 1]); Ch := NibbleH shl 4 or NibbleL; Result[i] := Chr(Ch); end; end; begin Stream.Read(l, 2); if l>0 then begin SetLength(ReportComment, l); Stream.Read(ReportComment[1], l); Report.ReportOptions.Description.Text := ReportComment; end; Stream.Read(l, 2); if l>0 then begin SetLength(ReportName, l); Stream.Read(ReportName[1], l); Report.ReportOptions.Name := ReportName; end; Stream.Read(l, 2); if l>0 then begin SetLength(ReportAuthor, l); Stream.Read(ReportAuthor[1], l); Report.ReportOptions.Author := ReportAuthor; end; Stream.Read(l, 2); if l>0 then begin SetLength(ReportVersionMajor, l); Stream.Read(ReportVersionMajor[1], l); Report.ReportOptions.VersionMajor := ReportVersionMajor; end; Stream.Read(l, 2); if l>0 then begin SetLength(ReportVersionMinor, l); Stream.Read(ReportVersionMinor[1], l); Report.ReportOptions.VersionMinor := ReportVersionMinor; end; Stream.Read(l, 2); if l>0 then begin SetLength(ReportVersionRelease, l); Stream.Read(ReportVersionRelease[1], l); Report.ReportOptions.VersionRelease := ReportVersionRelease; end; Stream.Read(l, 2); if l>0 then begin SetLength(ReportVersionBuild, l); Stream.Read(ReportVersionBuild[1], l); Report.ReportOptions.VersionBuild := ReportVersionBuild; end; Stream.Read(l, 2); if l>0 then begin SetLength(Buf, l); Stream.Read(Buf[1], l); ReportPassword := HexToStr(buf); Report.ReportOptions.Password := ReportPassword; end; Stream.Read(ReportGeneratorVersion, 1); Stream.Read(ReportPasswordProtected, SizeOf(Boolean)); Stream.Read(ReportCreateDate, SizeOf(TDateTime)); Report.ReportOptions.CreateDate := ReportCreateDate; Stream.Read(ReportLastChange, SizeOf(TDateTime)); Report.ReportOptions.LastChange := ReportLastChange; end; procedure TfrPagesLoadFromStream; var b, b1: Byte; w: Word; n: Integer; s: String; buf: String[8]; PrintToDefault: Boolean; begin Stream.Read(w{Parent.PrintToDefault}, 2); PrintToDefault := w <> 0; Stream.Read(w{Parent.DoublePass}, 2); Report.EngineOptions.DoublePass := w <> 0; s := ReadString(Stream); if (s = #1) or PrintToDefault then s := 'Default'; Report.PrintOptions.Printer := s; while Stream.Position < Stream.Size do begin Stream.Read(b, 1); if b = $FF then // page info TfrPageLoadFromStream else if b = $FE then // data dictionary TfrDictionaryLoadFromStream else if b = $FD then // data manager, not supported begin break; end else if b = $FC then // extra report data begin ReadReportOptions; break; end else begin if b > Integer(gtAddIn) then begin raise Exception.Create('Error in frf file'); break; end; s := ''; n := 0; try if b = gtAddIn then begin s := ReadString(Stream); if (AnsiUpperCase(s) = 'TFRBDELOOKUPCONTROL') or (AnsiUpperCase(s) = 'TFRIBXLOOKUPCONTROL') then s := 'TfrDBLookupControl'; if AnsiUpperCase(s) = 'TFRFRAMEDMEMOVIEW' then b := gtMemo; end; { object's page } Stream.Read(b1, 1); Page := Report.Pages[b1]; if Page is TfrxReportPage then begin offsx := Round(-TfrxReportPage(Page).LeftMargin * fr01cm); offsy := Round(-TfrxReportPage(Page).TopMargin * fr01cm); end else begin offsx := 0; offsy := 0; end; if frVersion > 23 then Stream.Read(n, 4); case b of gtMemo: TfrMemoViewLoadFromStream; gtPicture: TfrPictureViewLoadFromStream; gtBand: TfrBandViewLoadFromStream; gtSubReport: TfrSubreportLoadFromStream; gtLine: TfrLineViewLoadFromStream; gtAddIn: begin if CompareText(s, 'TfrLabelControl') = 0 then ReadTfrLabelControl else if CompareText(s, 'TfrEditControl') = 0 then ReadTfrEditControl else if CompareText(s, 'TfrMemoControl') = 0 then ReadTfrMemoControl else if CompareText(s, 'TfrButtonControl') = 0 then ReadTfrButtonControl else if CompareText(s, 'TfrCheckBoxControl') = 0 then ReadTfrCheckBoxControl else if CompareText(s, 'TfrRadioButtonControl') = 0 then ReadTfrRadioButtonControl else if CompareText(s, 'TfrListBoxControl') = 0 then ReadTfrListBoxControl else if CompareText(s, 'TfrComboBoxControl') = 0 then ReadTfrComboBoxControl else if CompareText(s, 'TfrDateEditControl') = 0 then ReadTfrDateEditControl { else if CompareText(s, 'TfrDBLookupControl') = 0 then ReadTfrDBLookupControl } else if CompareText(s, 'TfrBarCodeView') = 0 then ReadTfrBarCodeView else if CompareText(s, 'TfrChartView') = 0 then ReadTfrChartView else if CompareText(s, 'TfrCheckBoxView') = 0 then ReadTfrCheckBoxView else if CompareText(s, 'TfrCrossView') = 0 then ReadTfrCrossView else if CompareText(s, 'TfrOLEView') = 0 then ReadTfrOLEView else if CompareText(s, 'TfrRichView') = 0 then ReadTfrRichView else if CompareText(s, 'TfrRxRichView') = 0 then ReadTfrRichView else if CompareText(s, 'TfrRoundRectView') = 0 then ReadTfrRoundRectView else if CompareText(s, 'TfrShapeView') = 0 then ReadTfrShapeView else if CompareText(s, 'TfrBDEDatabase') = 0 then ReadTfrBDEDatabase else if CompareText(s, 'TfrBDETable') = 0 then ReadTfrBDETable else if CompareText(s, 'TfrBDEQuery') = 0 then ReadTfrBDEQuery else if CompareText(s, 'TfrADODatabase') = 0 then ReadTfrADODatabase else if CompareText(s, 'TfrADOTable') = 0 then ReadTfrADOTable else if CompareText(s, 'TfrADOQuery') = 0 then ReadTfrADOQuery else if CompareText(s, 'TfrIBXDatabase') = 0 then ReadTfrIBXDatabase else if CompareText(s, 'TfrIBXTable') = 0 then ReadTfrIBXTable else if CompareText(s, 'TfrIBXQuery') = 0 then ReadTfrIBXQuery end; end; if AnsiUpperCase(s) = 'TFRFRAMEDMEMOVIEW' then Stream.Read(buf[1], 8); if n <> 0 then Stream.Position := n; except if frVersion > 23 then begin if n = 0 then Stream.Read(n, 4); Stream.Seek(n, soFromBeginning); end; end; end; end; end; procedure TfrReportLoadFromStream; begin Stream.Read(frVersion, 1); TfrPagesLoadFromStream; end; procedure AdjustBands; var i, j: Integer; FObjects: TList; procedure TossObjects(Bnd: TfrxBand); var i: Integer; c: TfrxComponent; SaveRestrictions: TfrxRestrictions; begin if Bnd.Vertical then Exit; while Bnd.Objects.Count > 0 do begin c := Bnd.Objects[0]; SaveRestrictions := c.Restrictions; c.Restrictions := []; c.Top := c.AbsTop; c.Restrictions := SaveRestrictions; c.Parent := Bnd.Parent; end; for i := 0 to FObjects.Count - 1 do begin c := FObjects[i]; if (c is TfrxView) and (c.AbsTop >= Bnd.Top - 1e-4) and (c.AbsTop < Bnd.Top + Bnd.Height + 1e-4) then begin SaveRestrictions := c.Restrictions; c.Restrictions := []; c.Top := c.AbsTop - Bnd.Top; c.Restrictions := SaveRestrictions; c.Parent := Bnd; if c is TfrxStretcheable then if (TfrxStretcheable(c).StretchMode = smMaxHeight) and not Bnd.Stretched then TfrxStretcheable(c).StretchMode := smDontStretch; end; end; end; begin FObjects := TList.Create; for i := 0 to Report.PagesCount - 1 do begin Page := Report.Pages[i]; FObjects.Clear; for j := 0 to Page.AllObjects.Count - 1 do FObjects.Add(Page.AllObjects[j]); for j := 0 to FObjects.Count - 1 do if TObject(FObjects[j]) is TfrxBand then TossObjects(FObjects[j]); end; FObjects.Free; end; procedure ConnectDatasets; var l: TList; i: Integer; c: TfrxComponent; d: TfrxDataband; ds: TfrxDataset; cr: TfrxDBCrossView; c1: TComponent; s: String; begin l := Report.AllObjects; for i := 0 to l.Count - 1 do begin c := l[i]; if c is TfrxDataband then begin d := l[i]; s := d.DatasetName; if Pos('DialogForm._', s) = 1 then begin Delete(s, 1, Length('DialogForm._')); d.DatasetName := s; ds := d.DataSet; end else ds := frFindComponent(Report.Owner, d.DatasetName) as TfrxDataset; if ds <> nil then begin d.Dataset := ds; if Report.Datasets.Find(ds) = nil then Report.Datasets.Add(ds); end; end; if c is TfrxDBCrossView then begin cr := l[i]; c1 := frFindComponent(Report.Owner, cr.DatasetName); if c1 is TDataSet then begin ds := FindTfrxDataset(TDataSet(c1)); if ds <> nil then begin cr.Dataset := ds; if Report.Datasets.Find(ds) = nil then Report.Datasets.Add(ds); end; end; end; end; end; function ConvertDatasetAndField(s: String): String; var ds: TDataset; ds1: TfrxDataset; fld: String; begin ds := nil; fld := ''; if Pos(AnsiUppercase('DialogForm.'), AnsiUppercase(s)) = 1 then s := Copy(s, Length('DialogForm.') + 1, 255); Result := s; frGetDatasetAndField(s, ds, fld); if (ds <> nil) and (fld <> '') then begin ds1 := FindTfrxDataset(ds); if ds1 <> nil then Result := ds1.UserName + '."' + fld + '"'; end; end; procedure ConvertVariables; var i: Integer; v: TfrxVariable; begin for i := 0 to Report.Variables.Count - 1 do begin v := Report.Variables.Items[i]; v.Value := ConvertDatasetAndField(v.Value); end; end; procedure CheckCrosses; var l, l1: TList; i, j: Integer; c: TfrxComponent; cr: TfrxDBCrossView; v: TfrxMemoView; procedure AssignMemo(m, m1: TfrxCustomMemoView); var s: String; begin m.Visible := True; m.StretchMode := smDontStretch; s := m.Highlight.Condition; ExpandVariables1(s); m.Highlight.Condition := s; m1.Assign(m); if l1.IndexOf(m) = -1 then l1.Add(m); end; begin l := Report.AllObjects; l1 := TList.Create; for i := 0 to l.Count - 1 do begin c := l[i]; if c is TfrxDBCrossView then begin cr := l[i]; v := TfrxMemoView(Report.FindObject('ColumnHeaderMemo' + cr.Name)); if v <> nil then begin for j := 0 to cr.ColumnLevels - 1 do AssignMemo(v, cr.ColumnMemos[j]); end; v := TfrxMemoView(Report.FindObject('RowHeaderMemo' + cr.Name)); if v <> nil then begin for j := 0 to cr.RowLevels - 1 do AssignMemo(v, cr.RowMemos[j]); end; v := TfrxMemoView(Report.FindObject('ColumnTotalMemo' + cr.Name)); if v <> nil then begin for j := 0 to cr.ColumnLevels - 1 do AssignMemo(v, cr.ColumnTotalMemos[j]); end; v := TfrxMemoView(Report.FindObject('RowTotalMemo' + cr.Name)); if v <> nil then begin for j := 0 to cr.RowLevels - 1 do AssignMemo(v, cr.RowTotalMemos[j]); end; v := TfrxMemoView(Report.FindObject('GrandColumnTotalMemo' + cr.Name)); if v <> nil then begin AssignMemo(v, cr.ColumnTotalMemos[0]); end; v := TfrxMemoView(Report.FindObject('GrandRowTotalMemo' + cr.Name)); if v <> nil then begin AssignMemo(v, cr.RowTotalMemos[0]); end; v := TfrxMemoView(Report.FindObject('CellMemo' + cr.Name)); if v <> nil then begin if not cr.Border then v.Frame.Typ := [ftLeft, ftRight]; for j := 0 to cr.CellLevels - 1 do begin AssignMemo(v, cr.CellMemos[j]); if j <> 0 then cr.CellMemos[j].Frame.Typ := cr.CellMemos[j].Frame.Typ - [ftTop]; if j <> cr.CellLevels - 1 then cr.CellMemos[j].Frame.Typ := cr.CellMemos[j].Frame.Typ - [ftBottom]; end; cr.Border := True; end; end; end; for i := 0 to l1.Count - 1 do TObject(l1[i]).Free; l1.Free; end; procedure CheckCharts; var l: TList; i: Integer; c, c1: TfrxComponent; ch: TfrxChartView; dser: TfrxSeriesItem; begin l := Report.AllObjects; for i := 0 to l.Count - 1 do begin c := l[i]; if c is TfrxChartView then begin ch := l[i]; dser := ch.SeriesData[0]; c1 := Report.FindObject(dser.XSource) as TfrxComponent; if (c1 is TfrxMemoView) and (c1.Parent is TfrxDataBand) then begin dser.Databand := TfrxDataBand(c1.Parent); dser.XSource := TfrxMemoView(c1).Text; c1 := Report.FindObject(dser.YSource) as TfrxComponent; if c1 is TfrxMemoView then dser.YSource := TfrxMemoView(c1).Text; end; end; end; end; procedure CheckViews; var l: TList; i: Integer; c: TfrxComponent; v: TfrxView; s: String; ds: TfrxDataSet; fld: String; begin l := Report.AllObjects; for i := 0 to l.Count - 1 do begin c := l[i]; if c is TfrxView then begin v := l[i]; if v.DataField <> '' then if v.DataField[1] = '[' then begin s := Copy(v.DataField, 2, Length(v.DataField) - 2); if Report.Variables.IndexOf(s) <> -1 then s := Report.Variables[s] else s := ConvertDatasetAndField(s); ds := nil; fld := ''; Report.GetDatasetAndField(s, ds, fld); if (ds <> nil) and (fld <> '') then begin v.Dataset := ds; v.DataField := fld; end; end; end; end; end; procedure LoadFromFR2Stream(AReport: TfrxReport; AStream: TStream); begin Report := AReport; Stream := AStream; ClearFixups; Report.Clear; Report.ScriptText.Clear; TfrReportLoadFromStream; Report.ScriptText.Add('begin'); Report.ScriptText.Add(''); Report.ScriptText.Add('end.'); AdjustBands; FixupReferences; ConnectDatasets; ConvertVariables; CheckCrosses; CheckCharts; CheckViews; end; initialization Memo := TStringList.Create; Script := TStringList.Create; Fixups := TList.Create; fsModifyPascalForFR2; frxFR2EventsNew := TfrxFR2EventsNew.Create; frxFR2Events.OnGetValue := frxFR2EventsNew.DoGetValue; frxFR2Events.OnPrepareScript := frxFR2EventsNew.DoPrepareScript; frxFR2Events.OnLoad := frxFR2EventsNew.DoLoad; frxFR2Events.OnGetScriptValue := frxFR2EventsNew.DoGetScriptValue; finalization Memo.Free; Script.Free; Fixups.Free; frxFR2EventsNew.Free; end. //862fd5d6aa1a637203d9b08a3c0bcfb0