converterrb2fr.pas

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

{******************************************}
{                                          }
{             FastReport v4.0              }
{             RB -> FR  importer           }
{                                          }
{         Copyright (c) 1998-2008          }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit ConverterRB2FR ;

interface

{$I frx.inc}

implementation

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, Printers, TypInfo, Jpeg, DB,
  frxClass, frxVariables, frxPrinter, frxDCtrl, frxBarcode, frxBarcod,
  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
    function DoLoad(Sender: TfrxReport; Stream: TStream): Boolean;
  end;

  TppDuplex = (dpNone, dpHorizontal, dpVertical);
  TppFrame = (bpLeft, bpRight, bpTop, bpBottom);
  TShapeType = (stRectangle, stRoundRect, stEllipse, stSquare, stRoundSquare ,stCircle);
  TppBarTypes = (bcUPC_A, bcUPC_E, bcEAN_13, bcEAN_8, bcInt2of5, bcCode128, bcCode39, bcPostnet, bcFIM, bcCodabar, bcMSI);

  TAssignProp = procedure ();

var
  frxFR2EventsNew: TfrxFR2EventsNew;


function LoadFromRB(AReport: TfrxReport; AStream: TStream): Boolean;
Var
  Report: TfrxReport;
  Reader: TReader;
  SaveSeparator: Char;
  ClassName,ObjectName,PropName: string;
  Flags: TFilerFlags;
  Position: Integer;
  Val:Variant;
  LastObj: TfrxComponent;
  Parent: TfrxComponent;
  isBin: Boolean;
  Sig: String;
  CurY: Extended;
  DataBand: TfrxBand;


 function GetBoolValue(Str: String): Boolean;
 begin
  Result := False;
  If CompareStr(Str,'True') = 0 then
    Result := True;
 end;

 procedure AssignReport();
 var
   Page: TfrxReportPage;
   i: Integer;
 begin
  Page := LastObj as TfrxReportPage;
  {Page property}
  if PropName = 'PrinterSetup.mmPaperHeight' then
    Page.PaperHeight := Val/1000
  else if PropName = 'PrinterSetup.mmPaperWidth' then
    Page.PaperWidth := Val/1000
  else if PropName = 'PrinterSetup.mmMarginTop' then
    Page.TopMargin := Val/1000
  else if PropName = 'PrinterSetup.mmMarginBottom' then
    Page.BottomMargin := Val/1000
  else if PropName = 'PrinterSetup.mmMarginLeft' then
  begin
    Page.LeftMargin := Val/1000;
    for i := 0 to Page.ColumnPositions.Count - 1 do
      Page.ColumnPositions[i] := FloatToStr(StrToFloat(Page.ColumnPositions[i]) - Page.LeftMargin);
  end
  else if PropName = 'PrinterSetup.mmMarginRight' then
    Page.RightMargin := Val/1000
  else if PropName = 'PrinterSetup.PaperSize' then
    Page.PaperSize := Val
  else if PropName = 'PrinterSetup.BinName' then
    Page.Bin := frxPrinters.Printer.BinNameToNumber(Val)
  else if PropName = 'Columns' then
  begin
    Page.Columns := Val;
    Page.ColumnPositions.Clear;
  end
  else if PropName = 'ColumnPositions.Strings' then
    Page.ColumnPositions.Add(FloatToStr((StrToFloat(Val))/10000 * fr01in))
  else if PropName = 'mmColumnWidth' then
    Page.ColumnWidth := Val/10000 * fr01in
  else if PropName = 'PrinterSetup.Orientation' then
    Page.Orientation := TPrinterOrientation(GetEnumValue(TypeInfo(TPrinterOrientation), Val))
  else if PropName  = 'PrinterSetup.Duplex' then
    Page.Duplex := TfrxDuplexMode(GetEnumValue(TypeInfo(TppDuplex),Val))
  else if PropName = 'PrinterSetup.Copies' then
    Report.PrintOptions.Copies := Val
  else if PropName = 'PrinterSetup.PrinterName' then
    Report.PrintOptions.Printer := Val
  else if PropName = 'PrinterSetup.DocumentName' then
    Report.ReportOptions.Name := Val;
 end;

 procedure AssignHeader();
 var
  Header: TfrxHeader;
 begin
  Header := LastObj as TfrxHeader;
  if PropName = 'mmHeight' then
    Header.Height := Val / 10000 * fr1cm
 end;

 procedure AssignDBProp;
 var
  View: TfrxView;
 begin
   View := LastObj as TfrxView;
   if PropName = 'DataPipeline' then
    View.DataSetName := Val
   else if PropName = 'DataField' then
    View.DataField := Val;
 end;

 function GetCharsetByName(cName: String):TFontCharset;
 begin
   if cName = 'ANSI_CHARSET' then
     Result := ANSI_CHARSET
   else if cName = 'DEFAULT_CHARSET' then
     Result := DEFAULT_CHARSET
   else if cName = 'SYMBOL_CHARSET' then
     Result := SYMBOL_CHARSET
   else if cName = 'MAC_CHARSET' then
     Result := MAC_CHARSET
   else if cName = 'SHIFTJIS_CHARSET' then
     Result := SHIFTJIS_CHARSET
   else if cName = 'HANGEUL_CHARSET' then
     Result := HANGEUL_CHARSET
   else if cName = 'JOHAB_CHARSET' then
     Result := JOHAB_CHARSET
   else if cName = 'GB2312_CHARSET' then
     Result := GB2312_CHARSET
   else if cName = 'CHINESEBIG5_CHARSET' then
     Result := CHINESEBIG5_CHARSET
   else if cName = 'GREEK_CHARSET' then
     Result := GREEK_CHARSET
   else if cName = 'TURKISH_CHARSET' then
     Result := TURKISH_CHARSET
   else if cName = 'HEBREW_CHARSET' then
     Result := HEBREW_CHARSET
   else if cName = 'ARABIC_CHARSET' then
     Result := ARABIC_CHARSET
   else if cName = 'BALTIC_CHARSET' then
     Result := BALTIC_CHARSET
   else if cName = 'RUSSIAN_CHARSET' then
     Result := RUSSIAN_CHARSET
   else if cName = 'THAI_CHARSETT' then
     Result := THAI_CHARSET
   else if cName = 'EASTEUROPE_CHARSET' then
     Result := EASTEUROPE_CHARSET
   else if cName = 'OEM_CHARSET' then
     Result := OEM_CHARSET
   else
    Result := 1;
 end;

 procedure AssignFont;
 var
  View: TfrxView;
 begin
   View := LastObj as TfrxView;
   if View = nil then exit;
   if PropName = 'Font.Charset' then
    View.Font.Charset :=  GetCharsetByName(Val)
   else if PropName = 'Font.Color' then
    View.Font.Color := StringToColor(Val)
   else if PropName = 'Font.Name' then
    View.Font.Name := Val
   else if PropName = 'Font.Size' then
    View.Font.Size := Val
   else if PropName = 'Font.Style' then
    View.Font.Style := View.Font.Style + [TFontStyle(GetEnumValue(TypeInfo(TFontStyle), Val))]
 end;

 procedure AssignBorder;
 var
   frxView: TfrxView;
 begin
   frxView := lastObj as TfrxView;
   if frxView = nil then exit;
   if PropName = 'Border.BorderPositions' then
    frxView.Frame.Typ := frxView.Frame.Typ + [TfrxFrameType(GetEnumValue(TypeInfo(TppFrame),Val))]
   else if PropName = 'Border.Color' then
    frxView.Frame.Color := StringToColor(Val)
   else if PropName = 'Border.Style' then
    frxView.Frame.Style := TfrxFrameStyle(GetEnumValue(TypeInfo(TPenStyle),Val))
 end;

 procedure AssignMemo();
 var
   Memo: TfrxMemoView;
 begin
   Memo := LastObj as TfrxMemoView;

   if PropName = 'mmHeight' then
    Memo.Height := Val/10000 * fr1cm
   else if PropName = 'mmWidth' then
    Memo.Width := Val/10000 * fr1cm
   else if PropName = 'mmLeft' then
    Memo.Left := Val/10000 * fr1cm
   else if PropName = 'mmTop' then
    Memo.Top := Val/10000 * fr1cm
   else if (PropName = 'Caption') and (Memo.Text = '') then
    Memo.Text := Val
   else if PropName = 'UserName' then
    Memo.Name := Val
   else if PropName = 'Angle' then
    Memo.Rotation := Val
   else if PropName= 'Color' then
    Memo.Color := StringToColor(Val)
   else if PropName = 'CharWrap' then
    Memo.WordWrap := Val
   else if Pos('Border', PropName) = 1 then
    AssignBorder
   else if Pos('Font', PropName) = 1 then
    AssignFont
   else if PropName = 'BlankWhenZero' then
    Memo.HideZeros := Val
   else if PropName = 'SuppressRepeatedValues' then
    Memo.SuppressRepeated := Val
   else if PropName = 'TextAlignment' then
   begin
      if Val = 'taLeftJustified' then
        Memo.HAlign := haLeft
      else if Val = 'taRightJustified' then
        Memo.HAlign := haRight
      else if Val = 'taCentered' then
        Memo.HAlign := haCenter
      else if Val = 'taFullJustified' then
        Memo.HAlign := haBlock;
   end
   else if PropName = 'WordWrap' then
    Memo.WordWrap := Val
   else if PropName = 'Stretch' then
   begin
    if Val then
      Memo.StretchMode := smActualHeight
    else
      Memo.StretchMode := smDontStretch;
   end
   else if PropName = 'Lines.Strings' then
    Memo.Lines.Add(Val);
   if (Pos('DB', ClassName) = 4) and (Memo.DataSetName <> '') and (Memo.DataField <> '')  then
    Memo.Text := '['+ Memo.DataSetName + '."' + Memo.DataField + '"]'

{DBCalcType}
 end;

 procedure AssignBarCode;
  var
   Bar: TfrxBarCodeView;
 begin
   Bar := LastObj as TfrxBarCodeView;
   if Bar = nil then exit;
   if PropName = 'BarCodeType' then
   case GetEnumValue(TypeInfo(TppBarTypes),Val) of
     0: Bar.BarType := bcCodeUPC_A;
     1: Bar.BarType := bcCodeUPC_E0;
     2: Bar.BarType := bcCodeEAN13;
     3: Bar.BarType := bcCodeEAN8;
     4: Bar.BarType := bcCode_2_5_interleaved;
     5: Bar.BarType := bcCode128A;
     6: Bar.BarType := TfrxBarcodeType(12);
     7: Bar.BarType := bcCodePostNet;
     8: Bar.BarType := bcCode_2_5_industrial;
     9: Bar.BarType := bcCodeCodabar;
     10: Bar.BarType :=  bcCodeMSI;
   end
   else if PropName = 'Data' then
    Bar.Text := Val
   else if PropName = 'mmBarWidth' then
    Bar.Width := Val
   else if PropName = 'mmWideBarRatio' then
    Bar.WideBarRatio := Val
   else if PropName = 'PrintHumanReadable' then
    Bar.ShowText := Val
   else if PropName = 'BarColorCalcCheckDigit' then
    Bar.CalcCheckSum := Val
 end;

 procedure ObjectCreator(Name:String);
 begin
  if Name = 'TppReport' then
  begin
    LastObj := TfrxReportPage.Create(Report);
    Parent := LastObj;
    TfrxReportPage(LastObj).CreateUniqueName;
    TfrxReportPage(LastObj).SetDefaults;
  end
  else if Name = 'TppHeaderBand' then
  begin
    LastObj := TfrxHeader.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if Name = 'TppTitleBand' then
  begin
    LastObj := TfrxReportTitle.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if Name = 'TppColumnHeaderBand' then
  begin
    LastObj := TfrxColumnHeader.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppLabel') or (Name = 'TppSystemVariable')
       or (Name = 'TppVariable') or (Name = 'TppMemo')
       or (Name = 'TppDBText') or (Name = 'TppDBMemo') or (Name = 'TppDBCalc') then
  begin
    LastObj := TfrxMemoView.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppImage') or (Name = 'TppDBImage') then
  begin
    LastObj := TfrxPictureView.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppShape') then
  begin
    LastObj := TfrxShapeView.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppDetailBand') then
  begin
    LastObj := TfrxMasterData.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppColumnHeaderBand') then
  begin
    LastObj := TfrxColumnHeader.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppColumnFooterBand') then
  begin
    LastObj := TfrxColumnFooter.Create(Parent);
    LastObj.CreateUniqueName;
  end