frx2xto30.pas

这个是功能强大的报表软件

{******************************************}
{                                          }
{             FastReport v4.0              }
{             FR2.x importer               }
{                                          }
{         Copyright (c) 1998-2008          }
{         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;