frxexportrtf.pas

报表控件。FastReport 是非常强大的报表控件

              s2 := Copy(s1, j + 1, Length(s1) - j + 1);
              s0 := '\f' + GetRTFFontName(s2, 1);
              j := Pos('\f', s1);
              n := j + 1;
              while (n < Length(s1)) and (s1[n] <> '\') and (s1[n] <> ' ') do
                Inc(n);
              s2 := Copy(s1, j, n - j);
              j := Pos('}}', s);
              s1 := Copy(s, j + 2, Length(s) - j - 1);
              j := j + 2;
              n := 1;
              while n > 0 do
              begin
                n := Pos(s2, s1);
                if n > 0 then
                begin
                  if RepPos.IndexOf(IntToStr(n + j - 1)) = -1 then
                  begin
                    RepPos.Add(IntToStr(n + j - 1));
                    Delete(s, n + j - 1, Length(s2));
                    Insert(s0, s, n + j - 1);
                  end;
                  j := j + n + Length(s2) - 1;
                  s1 := Copy(s, j, Length(s) - j + 1);
                end;
              end;
            end;
            fx := Pos('}}', s);
            if fx > 0 then
              Delete(s, 1, fx + 1);
            fx := Pos('{\colortbl', s);
            if fx > 0 then
            begin
              Delete(s, 1, fx + 11);
              i := 1;
              n1 := 1;
              RepPos.Clear;
              while (i < Length(s)) and (s[i] <> '}') do
              begin
                while (i < Length(s)) and (s[i] <> '\') do
                  Inc(i);
                j := i;
                while (j < Length(s)) and (s[j] <> ';') do
                  Inc(j);
                Inc(j);
                s1 := Copy(s, i , j - i);
                i := j;
                s0 := '\cf' + GetRTFFontColor(s1);
                s2 := '\cf' + IntToStr(n1);
                j := Pos(';}', s);
                s1 := Copy(s, j + 2, Length(s) - j - 1);
                j := j + 2;
                n := 1;
                while n > 0 do
                begin
                  n := Pos(s2, s1);
                  if n > 0 then
                  begin
                    if RepPos.IndexOf(IntToStr(n + j - 1)) = -1 then
                    begin
                      RepPos.Add(IntToStr(n + j - 1));
                      Delete(s, n + j - 1, Length(s2));
                      Insert(s0, s, n + j - 1);
                    end;
                    j := j + n + Length(s2) - 1;
                    s1 := Copy(s, j, Length(s) - j + 1);
                  end;
                end;
                Inc(n1);
              end;
              fx := Pos(';}', s);
              if fx > 0 then
                Delete(s, 1, fx + 1);
            end;
            fx := Pos('{\stylesheet', s);
            if fx > 0 then
            begin
              Delete(s, 1, fx + 12);
              fx := Pos('}}', s);
              if fx > 0 then
                Delete(s, 1, fx + 1);
            end;
            s := StringReplace(s, '\pard', '', [rfReplaceAll]);
            Delete(s, Length(s) - 3, 3);

            fx := 1;
            while fx > 0 do
            begin
              fx := Pos('\lang', s);
              if fx > 0 then
              begin
                Delete(s, fx , 5);
                n := PosEx('\', s, fx);
                Delete(s, fx, n - fx);
              end;
            end;

            fx := 1;
            while fx > 0 do
            begin
              fx := Pos('\sa', s);
              if fx > 0 then
              begin
                Delete(s, fx , 3);
                n := PosEx('\', s, fx);
                Delete(s, fx, n - fx);
              end;
            end;

            fx := 1;
            while fx > 0 do
            begin
              fx := Pos('\sb', s);
              if fx > 0 then
              begin
                Delete(s, fx , 3);
                n := PosEx('\', s, fx);
                Delete(s, fx, n - fx);
              end;
            end;

            Obj.Memo.Text := s;
            RepPos.Free;
          end else if Obj.IsText then
          begin
            GetRTFFontColor(GetRTFColor(Obj.Style.Font.Color));
            GetRTFFontName(Obj.Style.Font.Name, Obj.Style.Charset);
          end;
        end;
      end;
    end;
end;

procedure TfrxRTFExport.ExportPage(const Stream: TStream);
var
  i, j, x, y, fx, fy, dx, dy, n, n1, pbk: Integer;
  dcol, drow, xoffs: Integer;
  buff, s, s0, s1, s2: String;
  CellsLine: String;
  Obj: TfrxIEMObject;
  Graphic: TGraphic;
  Str, CellsStream: TStream;
  bArr: array[0..1023] of Byte;
  FMode: Integer; // 3 - header, 2 - footer, 1 - body, 0 - stop

  procedure WriteExpLn(const str: string);
  begin
    if Length(str) > 0 then
    begin
      Stream.Write(str[1], Length(str));
      Stream.Write(#13#10, 2);
    end;
  end;

  procedure SetPageProp(Page: Integer);
  begin
    WriteExpLn('\pgwsxn' + IntToStr(Round(FMatrix.GetPageWidth(Page) * PageDivider)) +
               '\pghsxn' + IntToStr(Round(FMatrix.GetPageHeight(Page) * PageDivider)) +
               '\marglsxn' + IntToStr(Round(FMatrix.GetPageLMargin(Page) * MargDivider)) +
               '\margrsxn' + IntToStr(Round(FMatrix.GetPageRMargin(Page) * MargDivider)) +
               '\margtsxn' + IntToStr(Round(FMatrix.GetPageTMargin(Page) * MargDivider)) +
               '\margbsxn' + IntToStr(Round(FMatrix.GetPageBMargin(Page) * MargDivider)));
    if FMatrix.GetPageOrientation(Page) = poLandscape then
      WriteExpLn('\lndscpsxn');
  end;

begin
  PrepareExport;
  WriteExpLn('{\rtf1\ansi');
  s := '{\fonttbl';
  for i := 0 to FFontTable.Count - 1 do
  begin
    s1 := '{\f' + IntToStr(i) + '\fcharset' + FCharsetTable[i] +  ' ' + FFontTable[i] + '}';
    if Length(s + s1) < 255 then
      s := s + s1
    else
    begin
      WriteExpLn(s);
      s := s1;
    end;
  end;
  s := s + '}';
  WriteExpLn(s);
  s := '{\colortbl;';
  for i := 0 to FColorTable.Count - 1 do
  begin
    s1 := FColorTable[i];
    if Length(s + s1) < 255 then
      s := s + s1
    else
    begin
      WriteExpLn(s);
      s := s1;
    end;
  end;
  s := s + '}';
  WriteExpLn(s);
  WriteExpLn('{\info{\title ' + StrToRTFUnicode(Report.ReportOptions.Name) +
             '}{\author ' + StrToRTFUnicode(FCreator) +
             '}{\creatim\yr' + FormatDateTime('yyyy', Now) +
             '\mo' + FormatDateTime('mm', Now) + '\dy' + FormatDateTime('dd', Now) +
             '\hr' + FormatDateTime('hh', Now) + '\min' + FormatDateTime('nn', Now) + '}}');
  if ShowProgress then
    FProgress.Execute(FMatrix.Height - 1, frxResources.Get('ProgressWait'), True, True);
  pbk := 0;
  SetPageProp(pbk);

  if FHeaderFooterMode = hfPrint then
    FMode := 3
  else
    FMode := 1;
///
  while FMode > 0 do
  begin
    if FMode = 3 then
      WriteExpLn('{\header ')
    else if FMode = 2 then
      WriteExpLn('{\footer ');

    for y := 0 to FMatrix.Height - 2 do
    begin
      if ShowProgress then
      begin
        FProgress.Tick;
        if FProgress.Terminated then
          break;
      end;
      if FExportPageBreaks and (FMode = 1) then
        if FMatrix.PagesCount > pbk then
          if FMatrix.GetPageBreak(pbk) <= FMatrix.GetYPosById(y) then
          begin
  //          WriteExpLn('\pagebb\sect');
            WriteExpLn('\pard\sect');
            Inc(pbk);
            if pbk < FMatrix.PagesCount then
              SetPageProp(pbk);
            continue;
          end;
      drow := Round((FMatrix.GetYPosById(y + 1) - FMatrix.GetYPosById(y)) * Ydivider);
      buff := '\trrh' + IntToStr(drow)+ '\trgaph15';
      CellsStream := TMemoryStream.Create;
      try
        xoffs := Round(FMatrix.GetXPosById(1));
        for x := 1 to FMatrix.Width - 2 do
        begin
          i := FMatrix.GetCell(x, y);
          if (i <> -1) then
          begin
            Obj := FMatrix.GetObjectById(i);

            if (FMode = 3) and (not Obj.Header) then
              Continue;
            if (FMode = 2) and (not Obj.Footer) then
              Continue;
            if (FMode = 1) and (Obj.Header or Obj.Footer) and
               ((FHeaderFooterMode = hfPrint) or
                (FHeaderFooterMode = hfNone)) then
              Continue;

            FMatrix.GetObjectPos(i, fx, fy, dx, dy);
            if Obj.Counter = -1 then
            begin
              if dy > 1 then
                buff := buff + '\clvmgf';
              if (obj.Style.Color mod 16777216) <> clWhite then
                buff := buff + '\clcbpat' + GetRTFFontColor(GetRTFColor(Obj.Style.Color));
              buff := buff + GetRTFVAlignment(Obj.Style.VAlign) + GetRTFBorders(Obj.Style) + '\cltxlrtb';
              dcol := Round((Obj.Left + Obj.Width - xoffs) * Xdivider);
              buff := buff + '\cellx' + IntToStr(dcol);
              if Obj.IsText then
              begin
                s := '\f' + GetRTFFontName(Obj.Style.Font.Name, Obj.Style.Charset);
                if Length(Obj.Memo.Text) > 0 then
                  s := s + '\fs' + IntToStr(Obj.Style.Font.Size * 2)
                else
                begin
                  j := drow div FONT_DIVIDER;
                  if j > 20 then j := 20;
                  s := s + '\fs' + IntToStr(j);
                end;
                s := s + GetRTFFontStyle(Obj.Style.Font.Style);
                s := s + '\cf' + GetRTFFontColor(GetRTFColor(Obj.Style.Font.Color));
                if (Obj.IsRichText) then
                  s1 := Obj.Memo.Text
                else
                  s1 := StrToRTFUnicode(TruncReturns(Obj.Memo.Text));
                if Trim(s1) <> '' then
                begin
                  j := Round(Obj.Style.CharSpacing * FONT_DIVIDER);
                  s2 := '\sb' + IntToStr(Round(Obj.Style.GapY * Ydivider)) +
                      '\li' + IntToStr(Round((Obj.Style.GapX / 2) * Xdivider)) +
                      '\fi' + IntToStr(Round((Obj.Style.ParagraphGap) * Xdivider)) +
                      '\expnd' + IntToStr(j div 5) + '\expndtw' + IntToStr(j) +
                      '\sl' + IntToStr(Round((Obj.Style.Font.Size + Obj.Style.LineSpacing - 2) * Ydivider)) +
                      '\slmult0';
                  if Obj.Style.WordBreak then
                    s2 := s2 + '\hyphauto1\hyphcaps1';
                end else
                  s2 := '';
                CellsLine := GetRTFHAlignment(Obj.Style.HAlign) +
                  '{' + s + s2 + ' ' + s1 + '\cell}';
                s := '\par'#13#10'\cell';
                while Pos(s, CellsLine) > 0 do
                  CellsLine := StringReplace(CellsLine, s, '\cell', []);
                CellsStream.Write(CellsLine[1], Length(CellsLine));
              end
              else if FExportPictures then
              begin
                Graphic := Obj.Image;
                if not ((Graphic = nil) or Graphic.Empty) then
                begin
                  Str := TMemoryStream.Create;
                  try
                    dx := Round(Obj.Width);
                    dy := Round(Obj.Height);
                    fx := Graphic.Width;
                    fy := Graphic.Height;
                    Graphic.SaveToStream(Str);
                    Str.Position := 0;
                    CellsLine := '{\sb0\li0\sl0\slmult0 {\pict\wmetafile8\picw' + FloatToStr(Round(dx * IMAGE_DIVIDER)) +
                         '\pich' + FloatToStr(Round(dy * IMAGE_DIVIDER)) + '\picbmp\picbpp4' + #13#10;
                    CellsStream.Write(CellsLine[1], Length(CellsLine));
                    Str.Read(n, 2);