frx2xto30.pas

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

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 := '崶