frxexportrtf.pas

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

              while (i < Length(s)) and (s[i] <> '}') do
              begin
                while (i < Length(s)) and (s[i] <> '{') 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 - 2);
                i := j;
                j := Pos(' ', s1);
                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);
              s := TagClean(s, '\lang', '\');
              s := TagClean(s, '\sa', '\');
              s := TagClean(s, '\sb', '\');
              s := TagClean(s, '\sb', '\');
              s := TagClean2(s, '\cbpat', '\', '{');
              s := TagClean2(s, '\cfpat', '\', '{');

              Obj.Memo.Text :=  '{\par{' + s + '}\pard}';
            finally
              RepPos.Free;
            end;
//// RICH TEXT PREPARE END


          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;
  YDiv: Extended;
  dcol, drow, xoffs: Integer;
  buff, s, s0, s1, s2: String;
  st, st1: WideString;
  CellsLine: AnsiString;
  Obj: TfrxIEMObject;
  Graphic: TGraphic;
  Str, CellsStream: TStream;
  bArr: array[0..1023] of Byte;
  FMode: Integer; // 3 - header, 2 - footer, 1 - body, 0 - stop
  FHTMLTags: TfrxHTMLTagsList;
  Tag: TfrxHTMLTag;

  TagFColor: TColor;
  TagFStyleB, TagFStyleU, TagFStyleI: Integer;

  procedure WriteExpLn(const str: string);
{$IFDEF Delphi12}
  var
    TemsStr: AnsiString;
{$ENDIF}
  begin
{$IFDEF Delphi12}
    TemsStr := AnsiString(str);
    if Length(TemsStr) > 0 then
    begin
      Stream.Write(TemsStr[1], Length(TemsStr));
      Stream.Write(AnsiString(#13#10), 2);
    end;
{$ELSE}
    if Length(str) > 0 then
    begin
      Stream.Write(str[1], Length(str));
      Stream.Write(#13#10, 2);
    end;
{$ENDIF}
  end;

  procedure SetPageProp(Page: Integer);
  var
    s: String;
  begin
    s := '\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));
    WriteExpLn(s);
    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 ' + StrToRTFUnicodeEx(Report.ReportOptions.Name) +
             '}{\author ' + StrToRTFUnicodeEx(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;
///
  YDiv := Ydivider;
  while FMode > 0 do
  begin
    if FMode = 3 then
      WriteExpLn('{\header ')
    else if FMode = 2 then
      WriteExpLn('{\footer ');

    if FMatrix.PagesCount = 1 then
      YDiv := Ydivider_last;

    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 pbk < FMatrix.PagesCount then
          if FMatrix.GetPageBreak(pbk) <= FMatrix.GetYPosById(y) then
          begin
            WriteExpLn('\pard\sect');
            Inc(pbk);
            if pbk < FMatrix.PagesCount then
              SetPageProp(pbk);
            if pbk = FMatrix.PagesCount - 1 then
              YDiv := Ydivider_last;
            continue;
          end;
      drow := Round((FMatrix.GetYPosById(y + 1) - FMatrix.GetYPosById(y)) * YDiv);
      if FAutoSize then
        buff := '\trrh'
      else
        buff := '\trrh-';
      buff := buff + 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
                begin
                  // export HTML tags
                  if Obj.HTMLTags then
                  begin
                    FHTMLTags := TfrxHTMLTagsList.Create;
                    try
                      FHTMLTags.SetDefaults(Obj.Style.Font.Color, Obj.Style.Font.Size, Obj.Style.Font.Style);
                      FHTMLTags.AllowTags := True;
                      st := StrToRTFSlash(TruncReturns(Obj.Memo.Text));
                      st1 := st;
                      s1 := '';

                      TagFColor := Obj.Style.Color;
                      TagFStyleB := 0;
                      TagFStyleU := 0;
                      TagFStyleI := 0;

                      FHTMLTags.ExpandHTMLTags(st);
                      for i := 0 to FHTMLTags.Count - 1 do
                        for j := 0 to FHTMLTags[i].Count - 1 do
                        begin
                          Tag := FHTMLTags[i].Items[j];

                          // bold tags
                          if (fsBold in Tag.Style) and (TagFStyleB = 0) then
                          begin
                            Inc(TagFStyleB);
                            s1 := s1 + '\b ';
                          end;
                          if (TagFStyleB > 0) and (not (fsBold in Tag.Style)) then
                          begin
                            Dec(TagFStyleB);
                            s1 := s1 + '\b0 ';
                          end;

                          // italic tags
                          if (fsItalic in Tag.Style) and (TagFStyleI = 0) then
                          begin
                            Inc(TagFStyleI);
                            s1 := s1 + '\i ';
                          end;
                          if (TagFStyleI > 0) and (not (fsItalic in Tag.Style)) then
                          begin
                            Dec(TagFStyleI);
                            s1 := s1 + '\i0 ';
                          end;

                          // underline tags
                          if (fsUnderline in Tag.Style) and (TagFStyleU = 0) then
                          begin
                            Inc(TagFStyleU);
                            s1 := s1 + '\ul ';
                          end;
                          if (TagFStyleU > 0) and (not (fsUnderline in Tag.Style)) then
                          begin
                            Dec(TagFStyleU);
                            s1 := s1 + '\ul0 ';
                          end;

                          // color tags
                          if (Tag.Color <> Obj.Style.Font.Color) and (Tag.Color <> TagFColor) then
                          begin
                            TagFColor := Tag.Color;
                            s1 := s1 + '\cf' + GetRTFFontColor(GetRTFColor(TagFColor)) + ' ';
                          end;
                          if (Tag.Color <> TagFColor) then
                          begin
                            TagFColor := Tag.Color;
                            s1 := s1 + '\cf' + GetRTFFontColor(GetRTFColor(TagFColor)) + ' ';
                          end;

                          s1 := s1 + StrToRTFUnicode(st1[Tag.Position]);

                        end;
                        s1 := s1 + '\plain';
                    finally
                      FHTMLTags.Free;
                    end;
                  end
                  else
                    s1 := StrToRTFUnicodeEx(TruncReturns(Obj.Memo.Text));
                end;
                if Trim(s1) <> '' then
                begin
                  j := Round(Obj.Style.CharSpacing * FONT_DIVIDER);
                  if (Obj.Style.GapY + Obj.Style.LineSpacing - 1) > 0 then
                    n1 := Round((Obj.Style.GapY + Obj.Style.LineSpacing - 1) * YDiv)
                  else
                    n1 := 0;
                  s2 := '\sb' + IntToStr(n1) +
                      '\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.Height + Obj.Style.LineSpacing) * YDiv * 0.98)) +
                      '\slmult0';
                  if Obj.Style.WordBreak then
                    s2 := s2 + '\hyphauto1\hyphcaps1';
                end else
                  s2 := '';