fr_utils.pas

不错的报表工具

          s := frRemoveQuotes(ComplexName);
          Field := FindField(DataSet, s);
        end;
      end;
    1: // DatasetName.FieldName
      begin
        DataSet := TfrTDataSet(frFindComponent(f, sl[0]));
        s := frRemoveQuotes(sl[1]);
        Field := FindField(DataSet, s);
      end;
    2: // FormName.DatasetName.FieldName
      begin
        f := FindGlobalComponent(sl[0]);
        if f <> nil then
        begin
          DataSet := TfrTDataSet(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 := TfrTDataSet(cn.FindComponent(sl[2]));
          s := frRemoveQuotes(sl[3]);
          Field := FindField(DataSet, s);
        end;
      end;
  end;

  sl.Free;
end;

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;

{$HINTS OFF}
procedure frGetComponents(Owner: TComponent; ClassRef: TClass;
  List: TStrings; Skip: TComponent);
var
  i, j: Integer;

  procedure EnumComponents(f: TComponent);
  var
    i: Integer;
    c: TComponent;
  begin
{$IFDEF Delphi5}
    if f is TForm then
      for i := 0 to TForm(f).ControlCount - 1 do
      begin
        c := TForm(f).Controls[i];
        if c is TFrame then
          EnumComponents(c);
      end;
{$ENDIF}
    for i := 0 to f.ComponentCount - 1 do
    begin
      c := f.Components[i];
      if (c <> Skip) and (c is ClassRef) then
        if f = Owner then
          List.Add(c.Name)
        else if ((f is TForm) or (f is TDataModule)) then
          List.Add(f.Name + '.' + c.Name)
        else
          List.Add(TControl(f).Parent.Name + '.' + f.Name + '.' + c.Name)
    end;
  end;

begin
  List.Clear;
  for i := 0 to Screen.FormCount - 1 do
    EnumComponents(Screen.Forms[i]);
  for i := 0 to Screen.DataModuleCount - 1 do
    EnumComponents(Screen.DataModules[i]);
{$IFDEF Delphi6}
  with Screen do
    for i := 0 to CustomFormCount - 1 do
      with CustomForms[i] do
      if (ClassName = 'TDataModuleForm')  then
        for j := 0 to ComponentCount - 1 do
        begin
          if (Components[j] is TDataModule) then
            EnumComponents(Components[j]);
        end;
{$ENDIF}
end;
{$HINTS ON}

function frGetWindowsVersion: String;
var
  Ver: TOsVersionInfo;
begin
  Ver.dwOSVersionInfoSize := SizeOf(Ver);
  GetVersionEx(Ver);
  with Ver do begin
    case dwPlatformId of
      VER_PLATFORM_WIN32s: Result := '32s';
      VER_PLATFORM_WIN32_WINDOWS:
        begin
          dwBuildNumber := dwBuildNumber and $0000FFFF;
          if (dwMajorVersion > 4) or ((dwMajorVersion = 4) and
            (dwMinorVersion >= 10)) then
            Result := '98' else
            Result := '95';
        end;
      VER_PLATFORM_WIN32_NT: Result := 'NT';
    end;
  end;
end;

function frStrToFloat(s: String): Double;
var
  i: Integer;
begin
  for i := 1 to Length(s) do
    if s[i] in [',', '.'] then
      s[i] := DecimalSeparator;
  Result := StrToFloat(Trim(s));
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;

procedure frSetCommaText(Text: String; sl: TStringList);
var
  i: Integer;

  function ExtractCommaName(s: string; var Pos: Integer): string;
  var
    i: Integer;
  begin
    i := Pos;
    while (i <= Length(s)) and (s[i] <> ';') do Inc(i);
    Result := Copy(s, Pos, i - Pos);
    if (i <= Length(s)) and (s[i] = ';') then Inc(i);
    Pos := i;
  end;

begin
  i := 1;
  sl.Clear;
  while i <= Length(Text) do
    sl.Add(ExtractCommaName(Text, i));
end;

function frLoadStr(ID: Integer): String;
begin
  Result := frLocale.LoadStr(ID);
end;

function StrToXML(const s: String): String;
const
  SpecChars = ['<', '>', '"', #10, #13];
var
  i: Integer;

  procedure ReplaceChars(var s: String; i: Integer);
  begin
    Insert('#' + IntToStr(Ord(s[i])) + ';', s, i + 1);
    s[i] := '&';
  end;

begin
  Result := s;
  for i := Length(s) downto 1 do
    if s[i] in SpecChars then
      ReplaceChars(Result, i);
end;

type
  THackWriter = class(TWriter);

function frStreamToString(Stream: TStream): String;
var
  b: Byte;
begin
  Result := '';
  Stream.Position := 0;
  while Stream.Position < Stream.Size do
  begin
    Stream.Read(b, 1);
    Result := Result + IntToHex(b, 2);
  end;
end;

procedure SaveToFR3Stream(Report: TfrReport; Stream: TStream);
const
  fr01cm = 3.77953; // 96 / 25.4
  frKx = 96 / (93 / 1.015); // convert from 2.4 units to 3.0 units

  procedure WriteStr(const s: String);
  begin
    Stream.Write(s[1], Length(s));
  end;

  procedure WriteLn(const s: String);
  begin
    WriteStr(s + #13#10);
  end;

  function EncodePwd(const s: String): String;
  var
    i: Integer;
  begin
    Result := '';
    for i := 1 to Length(s) do
      Result := Result + Chr(Ord(s[i]) - 10);
  end;

  procedure WriteReportProp;

    procedure WriteScript;
    var
      i, j: Integer;
      Page: TfrPage;
      v: TfrView;
      Script: TStringList;

      procedure AddScript(const vName: String; vScript: TStrings);
      var
        i: Integer;
      begin
        if vScript.Count <> 0 then
        begin
          Script.Add('procedure ' + vName + 'OnBeforePrint(Sender: TfrComponent);');
          Script.Add('begin');
          Script.Add('  with ' + vName + ', Engine do');
          Script.Add('  begin');
          if vScript[0] <> 'begin' then
            Script.Add(vScript[0]);

          for i := 1 to vScript.Count - 2 do
            Script.Add(vScript[i]);

          if vScript[0] <> 'begin' then
          begin
            if vScript.Count <> 1 then
              Script.Add(vScript[vScript.Count - 1]);
            Script.Add('  end');
            Script.Add('end;');
          end
          else
          begin
            Script.Add('  end');
            Script.Add(vScript[vScript.Count - 1] + ';');
          end;
          Script.Add('');
        end;
      end;

    begin
      Script := TStringList.Create;
      for i := 0 to Report.Pages.Count - 1 do
      begin
        Page := Report.Pages[i];
        AddScript('Page' + IntToStr(i + 1), Page.Script);
        for j := 0 to Page.Objects.Count - 1 do
        begin
          v := Page.Objects[j];
          AddScript(v.Name, v.Script);
        end;
      end;

      Script.Add('begin');
      Script.Add('');
      Script.Add('end.');
      WriteStr(StrToXML(Script.Text) + '" ');
      Script.Free;
    end;

    procedure WriteVariables;
    var
      i: Integer;
      wr: THackWriter;
      ms: TMemoryStream;
      v: TValueType;
      varName, varValue: String;
    begin
      ms := TMemoryStream.Create;
      wr := THackWriter.Create(ms, 4096);

      v := vaCollection;
      wr.WriteStr('Datasets');
      wr.Write(v, SizeOf(v));
      wr.WriteListEnd;

      wr.WriteStr('Variables');
      wr.Write(v, SizeOf(v));

      for i := 0 to Report.Dictionary.Variables.Count - 1 do
      begin
        varName := Report.Dictionary.Variables.Name[i];
        varValue := Report.Dictionary.Variables.Value[i];

        wr.WriteListBegin;
        wr.WriteStr('Name');
        wr.WriteString(varName);
        wr.WriteStr('Value');
        wr.WriteString(varValue);
        wr.WriteListEnd;
      end;

      wr.WriteListEnd;
      wr.Free;
      WriteStr('Propdata="' + frStreamToString(ms) + '"');
      ms.Free;
    end;

  begin
    WriteStr('<TfrReport ScriptLanguage="Pascal" ScriptText.text="');
    WriteScript;
    WriteVariables;

    WriteStr(' ReportOptions.Name="' + StrToXML(Report.ReportName) + 
      '" ReportOptions.Author="' + StrToXML(Report.ReportAutor) + 
      '" ReportOptions.Description.text="' + StrToXML(Report.ReportComment) + 
      '" ReportOptions.CreateDate="' + DateTimeToStr(Report.ReportCreateDate) + 
      '" ReportOptions.LastChange="' + DateTimeToStr(Report.ReportLastChange) + 
      '" ReportOptions.VersionMajor="' + StrToXML(Report.ReportVersionMajor) + 
      '" ReportOptions.VersionMinor="' + StrToXML(Report.ReportVersionMinor) + 
      '" ReportOptions.VersionRelease="' + StrToXML(Report.ReportVersionRelease) + 
      '" ReportOptions.VersionBuild="' + StrToXML(Report.ReportVersionBuild) + 
      '" ReportOptions.Password="' + StrToXML(EncodePwd(Report.ReportPassword)) + '"');
    WriteLn('>');
  end;

  procedure WritePages;
  var
    i, j, ofx, savex: Integer;
    Page: TfrPage;
    v: TfrView;

    procedure WritePageProp(Page: TfrPage; const PageName: String);
    var
      s: String;
    begin
      ofx := 0;
      if Page.PageType = ptReport then
      begin
        if Page.pgOr = poPortrait then
          s := 'poPortrait' else
          s := 'poLandscape';
        WriteStr('<TfrReportPage Name="' + PageName + '" ');
        WriteStr('Orientation="' + s +
          '" PaperWidth="' + IntToStr(Round(Page.prnInfo.PgW / fr01cm * frKx)) +
          '" PaperHeight="' + IntToStr(Round(Page.prnInfo.PgH / fr01cm * frKx)) +
          '" PaperSize="' + IntToStr(Page.pgSize) + '" ');
        WriteStr('LeftMargin="' + IntToStr(Round(Page.LeftMargin / fr01cm * frKx)) +
          '" RightMargin="' + IntToStr(Round((Page.prnInfo.PgW - Page.RightMargin) / fr01cm * frKx)) +
          '" TopMargin="' + IntToStr(Round(Page.TopMargin / fr01cm * frKx)) +
          '" BottomMargin="' + IntToStr(Round((Page.prnInfo.PgH - Page.BottomMargin) / fr01cm * frKx)) +
          '" Columns="' + IntToStr(Page.ColCount) +
          '" ColumnWidth="' + IntToStr(Page.ColWidth) + '"');
        if Page.PrintToPrevPage then
          WriteStr(' PrintOnPreviousPage="True"');
        if Page.Script.Count > 0 then
          WriteStr(' OnBeforePrint="' + PageName + 'OnBeforePrint"');

        ofx := -Page.LeftMargin;
      end
      else
      begin
        WriteStr('<TfrDialogPage Name="' + PageName + '" ');
        WriteStr('Height="' + IntToStr(Page.Height) +
          '" Left="' + IntToStr(Page.Left) +
          '" Top="' + IntToStr(Page.Top) +
          '" Width="' + IntToStr(Page.Width) +
          '" BorderStyle="' + IntToStr(Page.BorderStyle) +
          '" Caption="' + StrToXML(Page.Caption) +
          '" Color="' + IntToStr(Page.Color) +
          '" Position="' + IntToStr(Page.Position) + '"');
        if Page.Script.Count > 0 then
          WriteStr(' OnActivate="' + PageName + 'OnBeforePrint"');
      end;
      if Page.Objects.Count = 0 then
        WriteLn('/>') else
        WriteLn('>');
    end;

  begin
    for i := 0 to Report.Pages.Count - 1 do
    begin
      Page := Report.Pages[i];
      WritePageProp(Page, 'Page' + IntToStr(i + 1));

      for j := 0 to Page.Objects.Count - 1 do
      begin
        v := Page.Objects[j];
        savex := v.x;
        v.x := v.x + ofx;
        v.SaveToFR3Stream(Stream);
        v.x := savex;
        WriteLn('/>');
      end;

      if Page.Objects.Count <> 0 then
        if Page.PageType = ptReport then
          WriteLn('</TfrReportPage>') else
          WriteLn('</TfrDialogPage>');
    end;
  end;

begin
  WriteLn('<?xml version="1.0"?>');
  WriteReportProp;
  WritePages;
  WriteLn('</TfrReport>');
end;

function frFieldIsNull(FieldName: String): Boolean;
var
  DS : TfrTDataSet;
  F : TfrTfield;
  FName: string;
begin
    Result := True;
    frGetDataSetAndField(FieldName, DS, FName);
    if DS <> nil then
    begin
      F := TfrTField(DS.FieldByName(FName));
      if f <> nil then
        Result := F.IsNull
    end
end;

end.