converterrb2fr.pas

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

    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppFooterBand') then
  begin
    LastObj := TfrxFooter.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppSummaryBand') then
  begin
    LastObj := TfrxReportSummary.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppBarCode') or (Name = 'TppDBBarCode') then
  begin
    LastObj := TfrxBarCodeView.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppRichText') or (Name = 'TppDBRichText') then
  begin
    LastObj := TfrxRichView.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TmyCheckBox') or (Name = 'TmyDBCheckBox') then
  begin
    LastObj := TfrxCheckBoxView.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppLine') then
  begin
    LastObj := TfrxLineView.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppGroupHeaderBand') then
  begin
    LastObj := TfrxGroupHeader.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else if (Name = 'TppGroupFooterBand') then
  begin
    LastObj := TfrxGroupFooter.Create(Parent);
    LastObj.CreateUniqueName;
  end
  else
    if LastObj.Parent <> nil then
      LastObj := LastObj.Parent;
 end;


 procedure AssignView;
 begin
     if PropName = 'mmHeight' then
      LastObj.Height := Val/10000 * fr1cm
    else if PropName = 'mmWidth' then
      LastObj.Width := Val/10000 * fr1cm
    else if PropName = 'mmLeft' then
      LastObj.Left := Val/10000 * fr1cm
    else if PropName = 'mmTop' then
      LastObj.Top := Val/10000 * fr1cm
    else if PropName = 'Visible' then
       LastObj.Visible := Val
 end;

 procedure AssignPicture;
 var
   Stream: TMemoryStream;
   Cn: Integer;
 begin
  if PropName = 'Picture.Data' then
    begin
      Stream := TMemoryStream.Create;
      Cn := 0;
      TMemoryStream(Integer(Val)).Position := 0;
      TMemoryStream(Integer(Val)).Read(Cn, 1);
      TMemoryStream(Integer(Val)).Position := Cn + 5;
      Stream.SetSize(TMemoryStream(Integer(Val)).Size - (Cn + 5));
      Stream.CopyFrom(TMemoryStream(Integer(Val)), Stream.Size);
      TfrxPictureView(LastObj).LoadPictureFromStream(Stream);
      Stream.Free;
    end;
 end;

 procedure AssignProp;
 begin
   if Pos('DB', ClassName) = 4 then
    AssignDBProp;
   if PropName = 'UserName' then
    LastObj.Name := Val
   else if ClassName = 'TppReport' then
     AssignReport
   {else if ClassName = 'TppHeaderBand' then
     AssignHeader}
   else if (ClassName = 'TppTitleBand') or (ClassName = 'TppColumnHeaderBand') or (ClassName = 'TppDetailBand')
   or (ClassName = 'TppColumnHeaderBand') or ( ClassName = 'TppColumnFooterBand') or (ClassName = 'TppFooterBand')
   or (ClassName = 'TppSummaryBand') or (ClassName = 'TppHeaderBand') or (ClassName = 'TppGroupHeaderBand')
   or (ClassName = 'TppGroupFooterBand') then
   begin
     if PropName = 'mmHeight' then
     begin
       TfrxBand(LastObj).Top := CurY;
       TfrxBand(LastObj).Height := Val / 10000 * fr1cm;
       CurY := CurY + TfrxBand(LastObj).Height;
     end
     else if PropName = 'Visible' then
       LastObj.Visible := Val
     else if (ClassName = 'TppGroupHeaderBand') then
     begin
        if DataBand <> nil then
        begin
          DataBand.FGroup := TfrxGroupHeader(LastObj);
        end
     end
     else if (ClassName = 'TppGroupFooterBand') then
     begin
     //
     end
     else if (ClassName = 'TppDetailBand') then
        DataBand := LastObj as TfrxBand
     else if(ClassName = 'TppSummaryBand') then
       if PropName = 'NewPage' then
         TfrxReportSummary(LastObj).StartNewPage := Val;
   end
   else if (ClassName = 'TppLabel') or (ClassName = 'TppSystemVariable') or (ClassName = 'TppVariable')
        or (ClassName = 'TppMemo') or (ClassName = 'TppDBText') or (ClassName = 'TppDBCalc')
        or (ClassName = 'TppDBMemo') then
     AssignMemo
   else if (ClassName = 'TppImage') or (ClassName = 'TppDBImage') then
   begin
     AssignView;
     AssignBorder;
     AssignPicture;
   end
   else if (ClassName = 'TppShape') then
   begin
     AssignView;
     if PropName = 'Shape' then
       if TShapeType(GetEnumValue(TypeInfo(TShapeType),Val)) in [stRectangle, stRoundRect, stEllipse] then
         TfrxShapeView(LastObj).Shape := TfrxShapeKind(GetEnumValue(TypeInfo(TPenStyle),Val));
   end
   else if (ClassName = 'TppBarCode') or (ClassName = 'TppDBBarCode') then
   begin
     AssignView;
     AssignBorder;
     AssignBarCode;
   end
   else if (ClassName = 'TppRichText') or (ClassName = 'TppDBRichText') then
   begin
     AssignView;
     AssignBorder;
     if PropName = 'RichText' then
      TfrxRichView(LastObj).RichEdit.Text := String(Val)
     else if PropName = 'Stretch' then
     begin
      if Val then
        TfrxRichView(LastObj).StretchMode := smActualHeight
      else
        TfrxRichView(LastObj).StretchMode := smDontStretch;
      end
   end
   else if (ClassName = 'TmyCheckBox') or (ClassName = 'TmyDBCheckBox') then
   begin
     AssignView;
     AssignBorder;
   end
   else if (ClassName ='TppLine') then
   begin
      AssignView;
      AssignBorder;
   end
 end;

  procedure ConvertBinary;
  var
    Count: Longint;
    Stream: TMemoryStream;
  begin
    Reader.ReadValue;
    Reader.Read(Count, SizeOf(Count));
    Stream := TMemoryStream.Create;
    Stream.SetSize(Count);
    Reader.Read(Stream.Memory^, Count);
    Val := Integer(Stream);
  end;

 procedure ReadProperty; forward;
 procedure ConvertValue;
  var
    L: Integer;
    S: string;
    W: WideString;
  begin
    case Reader.NextValue of
      vaList:
        begin
          Reader.ReadValue;
          while not Reader.EndOfList do
          begin
            ConvertValue;
          end;
          Reader.ReadListEnd;
          exit;
        end;
      vaInt8, vaInt16, vaInt32:
        Val := IntToStr(Reader.ReadInteger);
      vaExtended:
        Val := FloatToStrF(Reader.ReadFloat, ffFixed, 16, 18);
      vaSingle:
        Val := FloatToStr(Reader.ReadSingle) + 's';
      vaCurrency:
        Val := FloatToStr(Reader.ReadCurrency * 10000) + 'c';
      vaDate:
        Val := FloatToStr(Reader.ReadDate) + 'd';
      vaWString, vaUTF8String:
        begin
          W := Reader.ReadWideString;
          L := Length(W);
          if L = 0 then W :=  '';
          Val := W;
        end;
      vaString, vaLString:
        begin
          S := Reader.ReadString;
          L := Length(S);
          if L = 0 then S :=  '';
          Val := S;
        end;
      vaIdent, vaFalse, vaTrue, vaNil, vaNull:
        Val := Reader.ReadIdent;
      vaBinary:
        begin
          isBin := True;
          ConvertBinary;
        end;
      vaSet:
        begin
          Reader.ReadValue;

          while True do
          begin
            S := Reader.ReadStr;
            if S = '' then exit;
            Val := S;
            AssignProp;
          end;
        end;
      vaCollection:
        begin
          Reader.ReadValue;
          while not Reader.EndOfList do
          begin
            if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
            begin
              ConvertValue;
            end;
            Reader.CheckValue(vaList);
            while not Reader.EndOfList do ReadProperty;
            Reader.ReadListEnd;

          end;
          Reader.ReadListEnd;
        end;
      vaInt64:
        Val := IntToStr(Reader.ReadInt64);
    end;
      AssignProp;
  end;


 procedure ReadProperty;
  begin
    PropName := Reader.ReadStr;
    ConvertValue;
  end;

 procedure ReadObject;
  var
    LastParent: TfrxComponent;
  begin
    Reader.ReadPrefix(Flags, Position);
    if (ffInherited in Flags) or(ffInline in Flags)  then exit;
    ClassName := Reader.ReadStr;
    ObjectName := Reader.ReadStr;
    ObjectCreator(ClassName);
    LastParent := LastObj;
    while not Reader.EndOfList do
    begin
      ReadProperty;
      if isBin then
      begin
        TMemoryStream(Integer(Val)).Free;
        isBin := False;
      end;
    end;
    Reader.ReadListEnd;
    while not Reader.EndOfList do
    begin
      Parent := LastParent;
      ReadObject;
    end;
    Reader.ReadListEnd;
  end;
begin
  Result := False;
  Report := AReport;
  Report.Clear;
  SetLength(Sig, 3);
  AStream.Position := 0;
  AStream.Read(Sig[1], 3);
  AStream.Position := 0;
  if Sig <> 'TPF' then exit;
  Reader := TReader.Create(AStream, 4096);
  SaveSeparator := DecimalSeparator;
  isBin  := False;
  CurY := 0;
  DecimalSeparator := '.';
  try
    Reader.ReadSignature;
    Reader.ReadPrefix(Flags, Position);
    ReadObject;
    Result := True;
  finally
    Reader.Free;
  end;
  DecimalSeparator := SaveSeparator;
end;

function TfrxFR2EventsNew.DoLoad(Sender: TfrxReport; Stream: TStream): Boolean;
var
  Sig: String;
  TmpStream: TMemoryStream;
begin
  SetLength(Sig, 6);
  Stream.Position := 0;
  Stream.Read(Sig[1], 6);
  Stream.Position := 0;
  if Sig = 'object' then
  begin
    TmpStream := TMemoryStream.Create;
    try
      ObjectTextToBinary(Stream, TmpStream);
      Result := LoadFromRB(Sender, TmpStream);
    finally
      TmpStream.Free;
    end;
  end
  else
    Result := LoadFromRB(Sender, Stream);
end;



initialization
  frxFR2EventsNew := TfrxFR2EventsNew.Create;
  frxFR2Events.OnLoad := frxFR2EventsNew.DoLoad;
  frxFR2Events.Filter := '*.rtm';

finalization
  frxFR2EventsNew.Free;


end.