frxexportrtf.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

  Obj: TfrxIEMObject;
  Graphic: TGraphic;
  Str, CellsStream: TMemoryStream;
  bArr: array[0..1023] of Byte;

  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) + ' ' + 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 ' + Report.ReportOptions.Name +
             '}{\author ' + FCreator +
             '}{\creatim\yr' + FormatDateTime('yyyy', Now) +
             '\mo' + FormatDateTime('mm', Now) + '\dy' + FormatDateTime('dd', Now) +
             '\hr' + FormatDateTime('hh', Now) + '\min' + FormatDateTime('nn', Now) + '}}');
  if FShowProgress then
    FProgress.Execute(FMatrix.Height - 1, frxResources.Get('ProgressWait'), True, True);
  pbk := 0;
  SetPageProp(pbk);
  for y := 0 to FMatrix.Height - 2 do
  begin
    if FShowProgress then
    begin
      FProgress.Tick;
      if FProgress.Terminated then
        break;
    end;
    if FExportPageBreaks then
      if FMatrix.PagesCount > pbk then
        if FMatrix.GetPageBreak(pbk) <= FMatrix.GetYPosById(y) then
        begin
          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;
    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);
        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);
            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 := ChangeReturns(TruncReturns(Obj.Memo.Text));
            if Trim(s1) <> '' then
              s2 := '\sb' + IntToStr(Round(Obj.Style.GapY * Ydivider)) +
                  '\li' + IntToStr(Round((Obj.Style.GapX / 2) * Xdivider)) +
                  '\sl' + IntToStr(Round((Obj.Style.Font.Size + Obj.Style.LineSpacing) * Ydivider)) +
                  '\slmult0'
            else
              s2 := '';
            CellsLine := GetRTFHAlignment(Obj.Style.HAlign) +
              '{' + s + s2 + ' ' + s1 + '\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;
              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);
              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(fy, 4);
              s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
              s0 := IntToHex(fx, 4);
              s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) +
                '05000000090200000000050000000102ffffff000400000007010300' + s1 +
                '430f2000cc000000';
              s0 := IntToHex(fy, 4);
              s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
              s0 := IntToHex(fx, 4);
              s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) + '00000000';
              s0 := IntToHex(fy, 4);
              s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
              s0 := IntToHex(fx, 4);
              s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) + '00000000';
              CellsLine := s + #13#10;
              CellsStream.Write(CellsLine[1], Length(CellsLine));
              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;
                    CellsLine := s + #13#10;
                    CellsStream.Write(CellsLine[1], Length(CellsLine));
                    s := '';
                  end;
                end;
              until n < 1024;
              Str.Free;
              if n1 <> 0 then
              begin
                CellsLine := s + #13#10;
                CellsStream.Write(CellsLine[1], Length(CellsLine));
              end;
              s := '030000000000}';
              CellsLine := s + '\cell}' + #13#10;
              CellsStream.Write(CellsLine[1], Length(CellsLine));
            end;
          end;
          Obj.Counter := y + 1;
        end
        else
        begin
          if (dy > 1) and (Obj.Counter <> (y + 1))then
          begin
            buff := buff + '\clvmrg';
            buff := buff + GetRTFBorders(Obj.Style) + '\cltxlrtb';
            dcol := Round((Obj.Left + Obj.Width - xoffs) * Xdivider);
            buff := buff + '\cellx' + IntToStr(dcol);
            j := drow div FONT_DIVIDER;
            if j > 20 then
              j := 20;
            CellsLine := '{\fs' + IntToStr(j) + '\cell}';
            CellsStream.Write(CellsLine[1], Length(CellsLine));
            Obj.Counter := y + 1;
          end;
        end
      end
    end;
    if CellsStream.Size > 0 then
    begin
      s := '\trowd' + buff + '\pard\intbl';
      WriteExpLn(s);
      Stream.CopyFrom(CellsStream, 0);
      WriteExpLn('\pard\intbl{\trowd' + buff + '\row}');
    end;
    CellsStream.Free;
  end;
  WriteExpLn('}');
end;

function TfrxRTFExport.ShowModal: TModalResult;
begin
  if not Assigned(Stream) then
  begin
    with TfrxRTFExportDialog.Create(nil) do
    begin
      PicturesCB.Checked := FExportPictures;
      PageBreaksCB.Checked := FExportPageBreaks;
      WCB.Checked := FWysiwyg;
      OpenCB.Checked := FOpenAfterExport;

      Result := ShowModal;
      if Result = mrOk then
      begin
        PageNumbers := '';
        CurPage := False;
        if CurPageRB.Checked then
          CurPage := True
        else if PageNumbersRB.Checked then
          PageNumbers := PageNumbersE.Text;

        FExportPictures := PicturesCB.Checked;
        FExportPageBreaks := PageBreaksCB.Checked;
        FWysiwyg := WCB.Checked;
        FOpenAfterExport := OpenCB.Checked;

        if SaveDialog1.Execute then
          FileName := SaveDialog1.FileName
        else
          Result := mrCancel;
      end;
      Free;
    end;
  end else
    Result := mrOk;
end;

function TfrxRTFExport.Start: Boolean;
begin
  if (FileName <> '') or Assigned(Stream) then
  begin
    FFirstPage := True;
    FCurrentPage := 0;
    FMatrix := TfrxIEMatrix.Create;
    FMatrix.ShowProgress := FShowProgress;
    if FWysiwyg then
      FMatrix.Inaccuracy := 0.5
    else
      FMatrix.Inaccuracy := 10;
    FMatrix.RotatedAsImage := True;
    FMatrix.RichText := True;
    FMatrix.PlainRich := False;
    FMatrix.AreaFill := True;
    FMatrix.CropAreaFill := True;
    FMatrix.DeleteHTMLTags := True;
    FMatrix.BackgroundImage := False;
    FMatrix.Background := False;
    FMatrix.Printable := ExportNotPrintable;
    FFontTable := TStringList.Create;
    FColorTable := TStringList.Create;
    FDataList := TList.Create;
    Result := True
  end
  else
    Result := False;
end;

procedure TfrxRTFExport.StartPage(Page: TfrxReportPage; Index: Integer);
begin
  Inc(FCurrentPage);
  if FFirstPage then
    FFirstPage := False;
end;

procedure TfrxRTFExport.ExportObject(Obj: TfrxComponent);
begin
  if Obj is TfrxView then
    if (Obj is TfrxCustomMemoView) or
      (FExportPictures and (not (Obj is TfrxCustomMemoView))) then
        FMatrix.AddObject(TfrxView(Obj));
end;

procedure TfrxRTFExport.FinishPage(Page: TfrxReportPage; Index: Integer);
begin
  FMatrix.AddPage(Page.Orientation, Page.Width, Page.Height, Page.LeftMargin,
                  Page.TopMargin, Page.RightMargin, Page.BottomMargin);
end;

procedure TfrxRTFExport.Finish;
var
  Exp: TStream;
begin
  FMatrix.Prepare;
  if FShowProgress then
    FProgress := TfrxProgress.Create(nil);
  try
    if Assigned(Stream) then
      Exp := Stream
    else
      Exp := TFileStream.Create(FileName, fmCreate);
    try
      ExportPage(Exp);
    finally
      if not Assigned(Stream) then
        Exp.Free;
    end;
    if FOpenAfterExport and (not Assigned(Stream)) then
      ShellExecute(GetDesktopWindow, 'open', PChar(FileName), nil, nil, SW_SHOW);
  except
    on e: Exception do
      if Report.EngineOptions.SilentMode then
        Report.Errors.Add(e.Message)
      else frxErrorMsg(e.Message);
  end;
  FMatrix.Clear;
  FMatrix.Free;
  FFontTable.Free;
  FColorTable.Free;
  FDataList.Free;
  if FShowProgress then
    FProgress.Free;
end;

{ TfrxRTFExportDialog }

procedure TfrxRTFExportDialog.FormCreate(Sender: TObject);
begin
  frxResources.LocalizeForm(Self);
end;

end.