frrtfexp.pas

不错的报表工具

  end;

  function GetFontColor(f: String): String;
  var
    i: Integer;
  begin
    i := ColorTable.IndexOf(f);
    if i <> -1 then
      Result := IntToStr(i + 1)
    else
    begin
      ColorTable.Add(f);
      Result := IntToStr(ColorTable.Count);
    end;
  end;

  function GetFontName(f: String): String;
  var
    i: Integer;
  begin
    i := FontTable.IndexOf(f);
    if i <> -1 then
      Result := IntToStr(i)
    else
    begin
      FontTable.Add(f);
      Result := IntToStr(FontTable.Count - 1);
    end;
  end;

  function GetRtfAlignment(Alignment : Integer) : String;
  begin
    Result:='';
    if (Alignment and frtaLeft    )<>0 then Result:=Result+'\ql';
    if (Alignment and frtaRight   )<>0 then Result:=Result+'\qr';
    if (Alignment and frtaCenter  )<>0 then Result:=Result+'\qc';
    if (Alignment and frtaVertical)<>0 then Result:=Result+'\clvertalt';
    if (Alignment and frtaMiddle  )<>0 then Result:=Result+'\clvertalc';
    if (Alignment and frtaDown    )<>0 then Result:=Result+'\clvertalb';
    if Result='' then Result:='\ql';
  end;

begin
  if NewPage and PageBreaks then
  begin
    s := '\page' + #13#10;
    TempStream.Write(s[1], Length(s));
  end;
  if CurPage.pgOr = poLandscape then
  begin
    s := '\lndscpsxn ' + #13#10;
    TempStream.Write(s[1], Length(s));
  end;
 if expPictures then
    for i := 0 to DataList.Count - 1 do
    begin
      Str := TStream(DataList[i]);
      Str.Position := 0;
      Str.Read(x, 4);
      Str.Read(y, 4);
      Str.Read(dx, 4);
      Str.Read(dy, 4);
      s := '\pard\phmrg\posx' + FloatToStr(Round(x / (1 / expScaleX) * 15.05)) +
           '\posy' + FloatToStr(Round(y * 15.05 / 1)) +
           '\absh' + FloatToStr(Round(dy * 15.05)) +
           '\absw' + FloatToStr(Round(dx * 15.05)) +
           '{\pict\wmetafile8\picw' + FloatToStr(Round(dx * 26.46875)) +
           '\pich' + FloatToStr(Round(dy * 26.46875)) + ' \picbmp\picbpp4' + #13#10;
      TempStream.Write(s[1], Length(s));
      Str.Read(dx, 4);
      Str.Read(dy, 4);
      Str.Read(n, 2);
      Str.Read(n, 4);
      n := n div 2 + 7;
      s0 := IntToHex(n + $24, 8);
      s := '010009000003' + Copy(s0, 7, 2) + Copy(s0, 5, 2) +
           Copy(s0, 3, 2) + Copy(s0, 1, 2) + '0000';
      s0 := IntToHex(n, 8);
      s1 := Copy(s0, 7, 2) + Copy(s0, 5, 2) + Copy(s0, 3, 2) + Copy(s0, 1, 2);
      s := s + s1 + '0000050000000b0200000000050000000c02';
      s0 := IntToHex(dy, 4);
      s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
      s0 := IntToHex(dx, 4);
      s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) +
           '05000000090200000000050000000102ffffff000400000007010300' + s1 +
           '430f2000cc000000';
      s0 := IntToHex(dy, 4);
      s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
      s0 := IntToHex(dx, 4);
      s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) + '00000000';
      s0 := IntToHex(dy, 4);
      s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
      s0 := IntToHex(dx, 4);
      s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) + '00000000' + #13#10;
      TempStream.Write(s[1], Length(s));
      Str.Read(bArr[0], 8);
      n1 := 0; s := '';
      repeat
        n := Str.Read(bArr[0], 1024);
        for j := 0 to n - 1 do
        begin
          s := s + IntToHex(bArr[j], 2);
          Inc(n1);
          if n1 > 63 then
          begin
            n1 := 0;
            s := s + #13#10;
            TempStream.Write(s[1], Length(s));
            s := '';
          end;
        end;
      until n < 1024;
      Str.Free;
      if n1 <> 0 then
        TempStream.Write(s[1], Length(s));
      s := '030000000000}\par' + #13#10;
      TempStream.Write(s[1], Length(s));
    end;
    s := '\margtsxn0 ' + #13#10;
    TempStream.Write(s[1], Length(s));
    s :='\par ';
    TempStream.Write(s[1], Length(s));
    for i:=0  to PageObj.Count-1 do
    begin
      if TfrView(PageObj[i]) is TfrMemoView then
      begin
        Obj := TfrMemoView(PageObj[i]);
        x := Round(Obj.x / (1 / expScaleX) * 15.05);
        y := Round(Obj.y / (1 / expScaleY) * 15.05);
        dx := Round(Obj.dx / (1 / expScaleX) * 15.05);
        dy := Round(Obj.dy / (1 / expScaleY) * 15.05);
        s := '\trowd\posx'+IntToStr(x);
        s := s + '\posy'+IntToStr(y);
        s := s +'\absw'+IntToStr(dx);
        s := s +'\absh'+IntToStr(dy);
        s := s +'\trgaph5\trrh'+IntToStr(dy);
        s2 := CleanReturns(Obj.Memo.Text);
        if Obj.Font.Color = clWhite then
          Obj.Font.Color := clBlack;
        s1 := '\f' + GetFontName(Obj.Font.Name);
        s1 := s1 + '\fs' + IntToStr(Obj.Font.Size * 2);
        s1 := s1 + GetFontStyle(obj.Font.Style);
        s1 := s1 + '\cf' + GetFontColor(IntToStr(obj.Font.Color));
        s0 := '';
        If (obj.FillColor mod 16777216) <> clWhite then
          s0 := s0+'\clcbpat' + GetFontColor(IntToStr(Obj.FillColor));
        if (Obj.FrameTyp and frftLeft) <> 0 then
          s0:=s0+'\clbrdrl\brdrw15\brdrs';
        if (Obj.FrameTyp and frftRight) <> 0 then
          s0:=s0+'\clbrdrr\brdrw15\brdrs';
        if (Obj.FrameTyp and frftTop) <> 0 then
          s0:=s0+'\clbrdrt\brdrw15\brdrs';
        if (Obj.FrameTyp and frftBottom) <> 0 then
          s0:=s0+'\clbrdrb\brdrw15\brdrs';
        s := s + s0 + '\cellx' + IntToStr(dx) + GetRtfAlignment(obj.Alignment) + '{' + s1  + ' ' + s2 + '}\cell\pard\intbl\intbl\row\pard';
        TempStream.Write(s[1], Length(s));
      end
      else
      if TfrView(PageObj[i]) is TfrRichView then
      begin
        ObjR := TfrRichView(PageObj[i]);
        x := Round(ObjR.x / (1 / expScaleX) * 15.05);
        y := Round(ObjR.y / (1 / expScaleY) * 15.05);
        dx := Round(ObjR.dx / (1 / expScaleX) * 15.05);
        dy := Round(ObjR.dy / (1 / expScaleY) * 15.05);
        s := '\trowd\posx'+IntToStr(x);
        s := s + '\posy'+IntToStr(y);
        s := s +'\absw'+IntToStr(dx);
        s := s +'\absh'+IntToStr(dy);
        s := s +'\trgaph5\trrh'+IntToStr(dy);
        s0 := '';
        if (ObjR.FrameTyp and frftLeft) <> 0 then
          s0:=s0+'\clbrdrl\brdrw15\brdrs';
        if (ObjR.FrameTyp and frftRight) <> 0 then
          s0:=s0+'\clbrdrr\brdrw15\brdrs';
        if (ObjR.FrameTyp and frftTop) <> 0 then
          s0:=s0+'\clbrdrt\brdrw15\brdrs';
        if (ObjR.FrameTyp and frftBottom) <> 0 then
          s0:=s0+'\clbrdrb\brdrw15\brdrs';
        s := s + s0 + '\cellx' + IntToStr(dx)+ '{';
        TempStream.Write(s[1], Length(s));
        ObjR.RichEdit.PlainText :=  true;
        ObjR.RichEdit.Lines.SaveToStream(TempStream);
        s := '}\cell\pard\intbl\intbl\row\pard';
        TempStream.Write(s[1], Length(s));
      end;
    end;
  s := '\pard' + #13#10;
  TempStream.Write(s[1], Length(s));
  NewPage := True;
  DataList.Clear;
end;

procedure TfrRtfAdvExport.OnBeginDoc;
var
  buf : string;
begin
  NewPage := False;
  OnAfterExport := AfterExport;
  FontTable := TStringList.Create;
  ColorTable := TStringList.Create;
  DataList := TList.Create;
  TempStream := TMemoryStream.Create;
  buf := Format(TemplateStr, [Round(CurPage.pgWidth * 5.67), Round(CurPage.pgHeight * 5.67),
                              0,0,600,600]) + #13#10;
  Stream.Write(buf[1], Length(buf));
  CurrentPage := 0;
  CurY := 0;
  FirstPage := true;
  ClearLastPage;
  CY := 0;
  lastY := 0;
  CntPics := 0;
end;

procedure TfrRtfAdvExport.OnBeginPage;
begin
  Inc(CurrentPage);
  ObjCellAdd(RX, 0);
  ObjCellAdd(RY, 0);
end;

procedure TfrRtfAdvExport.OnData(x, y: Integer; View: TfrView);
var
    MemoView : TfrMemoView;
    RichView : TfrRichView;
    PicView : TfrPictureView;
    ind : integer;
    bit : TBitmap;
    Str: TStream;
    n: Integer;
    Graphic: TGraphic;

begin
  ind := 0;
  CY := 0;
  if (pgList.Find(IntToStr(CurrentPage),ind)) or (pgList.Count = 0) then
  begin
      if View is TfrMemoView then
      begin
        if (TfrMemoView(View).Memo.Count > 0) or (TfrMemoView(View).FrameTyp > 0) then
        begin
          MemoView := TfrMemoView.Create;
          MemoView.Assign(View);
          PageObj.Add(MemoView);
          ObjCellAdd(RX, View.x);
          ObjCellAdd(RX, View.x + View.dx);
          ObjCellAdd(RY, View.y + CY);
          ObjCellAdd(RY, View.y + View.dy + CY);
        end;
      end
      else
      if View is TfrRichView then
      begin
          RichView := TfrRichView.Create;
          RichView.Assign(View);
          PageObj.Add(RichView);
          ObjCellAdd(RX, View.x);
          ObjCellAdd(RX, View.x + View.dx);
          ObjCellAdd(RY, View.y + CY);
          ObjCellAdd(RY, View.y + View.dy + CY);
      end
      else
      begin
          PicView := TfrPictureView.Create;
          PicView.x := View.x;
          PicView.y := View.y;
          PicView.dx := View.dx;
          PicView.dy := View.dy;
          bit := TBitmap.Create;
          bit.Height := View.dy+1;
          bit.Width := View.dx+1;
          View.x := 0;
          View.y := 0;
          View.Draw(bit.Canvas);
          View.x := PicView.x;
          View.y := PicView.y;
          PicView.Picture.Bitmap.Assign(bit);
          bit.Destroy;
          PicView.y := PicView.y + CY;
        Graphic := TfrPictureView(PicView).Picture.Graphic;
        if not ((Graphic = nil) or Graphic.Empty) then
        begin
          Str := TMemoryStream.Create;
          Str.Write(x, 4);
          Str.Write(y, 4);
          Str.Write(View.dx, 4);
          Str.Write(View.dy, 4);
          n := Graphic.Width;
          Str.Write(n, 4);
          n := Graphic.Height;
          Str.Write(n, 4);
          Graphic.SaveToStream(Str);
          DataList.Add(Str);
        end;
        PicView.Free;
      end;
   end;
end;

procedure TfrRtfAdvExport.OnEndPage;
var
  ind: integer;
begin
  CY := LastY;
  ind := 0;
  RX.Sort(@ComparePoints);
  RY.Sort(@ComparePoints);
  DeleteMultiplePoint(RX);
  DeleteMultiplePoint(RY);
  PageObj.Sort(@CompareObjects);
  OrderObjectByCells;
  if (pgList.Find(IntToStr(CurrentPage),ind)) or (pgList.Count = 0) then
    ExportPage;
  ClearLastPage;
end;

procedure TfrRtfAdvExport.OnEndDoc;
var
  i, c: Integer;
  s, s1: String;
begin
  s := '\par}';
  TempStream.Write(s[1], Length(s));
  s := '{\fonttbl';
  for i := 0 to FontTable.Count - 1 do begin
    s1 := '{\f' + IntToStr(i) + ' ' + FontTable[i] + '}';
    if Length(s + s1) < 255 then
      s := s + s1
    else begin
      s := s + #13#10;
      Stream.Write(s[1], Length(s));
      s := s1;
    end;
  end;
  s := s + '}' + #13#10;
  Stream.Write(s[1], Length(s));
  s := '{\colortbl;';
  for i := 0 to ColorTable.Count - 1 do begin
    c := StrToInt(ColorTable[i]);
    s1 := '\red' + IntToStr(GetRValue(c)) +
          '\green' + IntToStr(GetGValue(c)) +
          '\blue' + IntToStr(GetBValue(c)) + ';';
    if Length(s + s1) < 255 then
      s := s + s1
    else begin
      s := s + #13#10;
      Stream.Write(s[1], Length(s));
      s := s1;
    end;
  end;
  s := s + '}' + #13#10;
  Stream.Write(s[1], Length(s));
  Stream.CopyFrom(TempStream, 0);
  TempStream.Free;
  FontTable.Free;
  ColorTable.Free;
  DataList.Free;
end;

procedure TfrRtfAdvExport.AfterExport(const FileName: string);
begin

end;

procedure TfrRtfExpSet.Localize;
begin
  Ok.Caption := frLoadStr(SOk);
  Cancel.Caption := frLoadStr(SCancel);
  GroupPageRange.Caption := frLoadStr(frRes + 44);
  Pages.Caption := frLoadStr(frRes + 47);
  Descr.Caption := frLoadStr(frRes + 48);
  Caption := frLoadStr(frRes + 1871);
  GroupPageSettings.Caption := frLoadStr(frRes + 1845);
  Topm.Caption := frLoadStr(frRes + 1846);
  Leftm.Caption := frLoadStr(frRes + 1847);
  ScX.Caption := frLoadStr(frRes + 1848);
  ScY.Caption := frLoadStr(frRes + 1849);
  GroupCellProp.Caption := frLoadStr(frRes + 1850);
  CB_PageBreaks.Caption := frLoadStr(frRes + 1860);
  CB_Pictures.Caption := frLoadStr(frRes + 1863);
end;

procedure TfrRtfExpSet.FormCreate(Sender: TObject);
begin
   Localize;
end;

end.