rm_e_rtf.pas

来自「report machine 2.3 功能强大」· PAS 代码 · 共 741 行 · 第 1/2 页

                  s := s + #13#10;
                  WriteToTempStream(s);
                  s := '';
                end;
              end;
            until n < 1024;
            if n1 <> 0 then
              WriteToTempStream(s);

            STemp := '030000000000' + CRLF;
          end
          else
          begin
            if FGraphicDataInBinary then
              STemp := '\bin' + IntToStr(Length(S)) + ' ' + S
            else
              STemp := GetBinHex(S);
          end;
          STemp := STemp + '}' + CRLF;
          WriteToTempStream(STemp);
        finally
          DataRec^.Bitmap.Free;
          AStream.Free;
        end;
      end;
    end;

  // Export Frames
    if ExportFrames then
    begin
      liFlag := (DataRec^.ViewClassName = TRMMemoView.ClassName) or (DataRec^.ViewClassName = TRMCalcMemoView.ClassName);
      if (liFlag and not DataRec^.VerticalText) or (DataRec^.ViewClassName = TRMLineView.ClassName) then
      begin
        if DataRec^.Text <> '' then
        begin
          ABorderInfo := GetTextBorderInfo;
          if ABorderInfo = '' then
          begin
            ABorderInfo := '\absw' + NumToStr(AWidth);
            if not DataRec^.Stretched then
              ABorderInfo := '\absh-' + NumToStr(AHeight) + ABorderInfo;
          end;
          SFrame := '\par\pard' + ABorderInfo + '\pvpg\phpg';
          SFrame := SFrame +
            '\posy' + NumToStr(GetNativePos(DataRec^.Y)) +
            '\posx' + NumToStr(GetNativePos(DataRec^.X));
          if DataRec^.FrameInfo.FillColor <> clNone then
          begin
            SFrame := SFrame + '\shading10000\cfpat' +
              NumToStr(GetColorNumInColorTbl(DataRec^.FrameInfo.FillColor));
            SFrame := SFrame + ' ';
          end;
        end
        else
        begin
     // ****** Word 95 and above ******
          ShadeAttrib := '\dpfillpat0';
          if DataRec^.FrameInfo.FillColor <> clNone then
            ShadeAttrib :=
              '\dpfillfgcr' +
              ExtractColorValue(cbRed, DataRec^.FrameInfo.FillColor) +
              '\dpfillfgcg' +
              ExtractColorValue(cbGreen, DataRec^.FrameInfo.FillColor) +
              '\dpfillfgcb' +
              ExtractColorValue(cbBlue, DataRec^.FrameInfo.FillColor) +
              '\dpfillbgcr' +
              ExtractColorValue(cbRed, DataRec^.FrameInfo.FillColor) +
              '\dpfillbgcg' +
              ExtractColorValue(cbGreen, DataRec^.FrameInfo.FillColor) +
              '\dpfillbgcb' +
              ExtractColorValue(cbBlue, DataRec^.FrameInfo.FillColor) +
              '\dpfillpat1';

          LineAttrib :=
            '\dplinecor' +
            ExtractColorValue(cbRed, DataRec^.FrameInfo.FrameColor) +
            '\dplinecog' +
            ExtractColorValue(cbGreen, DataRec^.FrameInfo.FrameColor) +
            '\dplinecob' +
            ExtractColorValue(cbBlue, DataRec^.FrameInfo.FrameColor) +
            '\dplinew' + NumToStr(GetNativePos(DataRec^.FrameInfo.FrameWidth));

          SFrame := EncodeFrame;
          SFrame := '{\lang1024 ' + SFrame + '}';
        end;
      end;
      WriteToTempStream(SFrame);
    end;

  // Export Text
    liFlag := (DataRec^.ViewClassName = TRMMemoView.ClassName) or (DataRec^.ViewClassName = TRMCalcMemoView.ClassName);
    if (liFlag and not DataRec^.VerticalText) and (DataRec^.Text <> '') then
    begin
      TextAlignment := '';
      if eftpAlignLeft in DataRec^.TextAlign then
        TextAlignment := '\ql'
      else if eftpAlignRight in DataRec^.TextAlign then
        TextAlignment := '\qr'
      else if eftpAlignCenter in DataRec^.TextAlign then
        TextAlignment := '\qc'
      else if eftpAlignJustify in DataRec^.TextAlign then
        TextAlignment := '\qj';

      if eftpAlignTop in DataRec^.TextAlign then
        TextAlignment := '\vertalt' + TextAlignment
      else if eftpAlignBottom in DataRec^.TextAlign then
        TextAlignment := '\vertalb' + TextAlignment
      else if eftpAlignVerticalCenter in DataRec^.TextAlign then
        TextAlignment := '\vertalc' + TextAlignment;

      EncodedText := GetNativeText(DataRec^.Text);
      EncodedText := EncodedText + CRLF;

   // add font to font list if new
      fn := FFontTable.IndexOf(Datarec^.FontInfo.Name);
      if Fn = -1 then
        Fn := FFontTable.Add(Datarec^.FontInfo.Name);

      FTextAttribSetStr :=
        '\f' + IntToStr(Fn) +
        '\cf' + IntToStr(GetColorNumInColorTbl(Datarec^.FontInfo.Color)) +
        '\fs' + IntToStr(Datarec^.FontInfo.Size * 2) +
        Bold[fsBold in Datarec^.FontInfo.Style] +
        Italic[fsItalic in Datarec^.FontInfo.Style] +
        StrikeOut[fsStrikeOut in Datarec^.FontInfo.Style] +
        UnderLine[fsUnderLine in Datarec^.FontInfo.Style] +
        TextAlignment;

      FTextAttribResetStr :=
        Bold0[fsBold in Datarec^.FontInfo.Style] +
        Italic0[fsItalic in Datarec^.FontInfo.Style] +
        StrikeOut0[fsStrikeOut in Datarec^.FontInfo.Style] +
        UnderLine0[fsUnderLine in Datarec^.FontInfo.Style];

      if DataRec^.Text <> '' then
      begin
        if not ExportFrames then
        begin
          SText := '\par\pard\pvpg\phpg' + '\absw' + NumToStr(AWidth);
          if not DataRec^.Stretched then
            SText := SText + '\absh-' + NumToStr(AHeight);
          SText := SText + '\posy' + NumToStr(ATop) +
            '\posx' + NumToStr(ALeft);
        end;

        EncodedText := SText + FTextAttribSetStr + ' ' + EncodedText + ' ' +
          FTextAttribResetStr;
      end;
      EncodedText := EncodedText + CRLF;
      WriteToTempStream(EncodedText);
    end;
  end;
  S := '\par\page}' + CRLF;

  if (FPageNo = CurReport.EMFPages.Count - 1) then
    S := '\par}' + CRLF;

  WriteToTempStream(S);
  inherited;
end;

function TRMRTFExport.WriteHeader;
var
  S: string;
  PageWidth, PageHeight: Extended;
  LeftMargin, RightMargin, TopMargin, BottomMargin: Extended;
begin
  PageWidth := GetNativePos(FPageWidth);
  PageHeight := GetNativePos(FPageHeight);
  LeftMargin := GetNativePos(CurPage.pgMargins.Left);
  RightMargin := GetNativePos(CurPage.pgMargins.Right);
  TopMargin := GetNativePos(CurPage.pgMargins.Top);
  BottomMargin := GetNativePos(CurPage.pgMargins.Bottom);

  S := '{\rtf1\ansi\ansicpg' + IntToStr(GetACP) +
    '\deff0\deftab720' +
    '{\fonttbl' + MakeFontTable + '}' +
    '{\colortbl;' + MakeColorTable + '}' +
    '{\info{\title ' + CurReport.Title + '}' +
    '{\creatim' +
    FormatDateTime('"\yr"yyyy"\mo"m"\dy"d"\hr"h"\min"n', Now) + '}}' +
    '\viewkind1' +
    '\paperw' + NumToStr(PageWidth) +
    '\paperh' + NumToStr(PageHeight) +
    '\margl' + NumToStr(LeftMargin) +
    '\margr' + NumToStr(RightMargin) +
    '\margt' + NumToStr(TopMargin) +
    '\margb' + NumToStr(BottomMargin);
  if (CurReport.EMFPages.Pages[0].pgOr = poLandscape) then
    S := S + '\landscape';
  S := S + '\headery0\footery0';
  S := S + CRLF;
  Stream.Write(Pointer(S)^, Length(S));
end;

function TRMRTFExport.GetColorNumInColorTbl(AColor: TColor): Integer;
begin
 // add color to color list
  Result := FColorTable.IndexOf(ColorBGRToRGB(AColor));
  if Result = -1 then
    Result := FColorTable.Add(ColorBGRToRGB(AColor));
  Inc(Result);
end;

function TRMRTFExport.MakeColorTable: string;
var
  I: Integer;
begin
  Result := '';
  for I := 0 to FColorTable.Count - 1 do
    Result := Result +
      '\red' + HexToInt(Copy(FColorTable[I], 1, 2)) +
      '\green' + HexToInt(Copy(FColorTable[I], 3, 2)) +
      '\blue' + HexToInt(Copy(FColorTable[I], 5, 2)) + ';';
end;

function TRMRTFExport.HexToInt(HexCode: string): string;
begin
  Result := IntToStr(StrToIntDef('$' + HexCode, 0));
end;

function TRMRTFExport.MakeFontTable: string;
var
  I: Integer;
begin
  Result := '';
  for I := 0 to FFontTable.Count - 1 do
    Result := Result + '{\f' + IntToStr(I) + '\fnil ' + FFontTable[I] + ';}';
end;

function TRMRTFExport.ColorBGRToRGB(AColor: TColor): string;
begin
  Result := IntToHex(ColorToRGB(AColor), 6);
  Result := Copy(Result, 5, 2) + Copy(Result, 3, 2) + Copy(Result, 1, 2);
end;

function TRMRTFExport.GetNativePos(X: Extended): Extended;
begin
 // convert to Twips
  Result := (X / CmmToPixel / CFRUnitsPerInch) * CInchToPoint * cPointToTwip;
end;

function TRMRTFExport.NumToStr(N: Extended): string;
begin
  Result := IntToStr(Round(N));
end;

function TRMRTFExport.GetNativeText(const Text: string): string;
var
  Str: string;
begin
  Str := Text;
  if Copy(Str, Length(Str) - 1, 2) = CRLF then
    Delete(Str, Length(Str) - 1, 2);
  Result := RMReplaceString(Str, '\', '\\');
  Result := RMReplaceString(Result, '{', '\{');
  Result := RMReplaceString(Result, '}', '\}');
  Result := RMReplaceString(Result, CRLF, CRLF + '\par ');
end;

procedure TRMRTFExport.WriteToTempStream(AText: string);
begin
  FTempStream.Write(Pointer(AText)^, Length(AText));
end;

function TRMRTFExport.ShowModal: Word;
begin
  if not ShowDialog then
    Result := mrOk
  else
    with TRMRTFExportForm.Create(nil) do
    try
      ExportFilter := Self;
      Result := ShowModal;
    finally
      Free;
    end;
end;


{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMRTFExportForm}

procedure TRMRTFExportForm.Localize;
begin
  Font.Name := RMLoadStr(SRMDefaultFontName);
  Font.Size := StrToInt(RMLoadStr(SRMDefaultFontSize));
  Font.Charset := StrToInt(RMLoadStr(SCharset));

  Caption := RMLoadStr(rmRes + 1820);
  chkExportFrames.Caption := RMLoadStr(rmRes + 1803);
  chkExportImages.Caption := RMLoadStr(rmRes + 1821);
  lblExportImageFormat.Caption := RMLoadStr(rmRes + 1816);
  lblJPEGQuality.Caption := RMLoadStr(rmRes + 1814);
  btnOk.Caption := RMLoadStr(SOK);
  btnCancel.Caption := RMLoadStr(SCancel);
end;

procedure TRMRTFExportForm.FormCreate(Sender: TObject);
begin
  Localize;
  cbImageFormat.Items.Clear;
{$IFDEF JPEG}
  cbImageFormat.Items.AddObject(ImageFormats[ifJPG], TObject(ifJPG));
{$ENDIF}
  cbImageFormat.Items.AddObject(ImageFormats[ifBMP], TObject(ifBMP));
end;

procedure TRMRTFExportForm.chkExportImagesClick(Sender: TObject);
begin
  RMSetControlsEnable(gbExportImages, chkExportImages.Checked);
  cbImageFormatChange(Sender);
end;

procedure TRMRTFExportForm.FormShow(Sender: TObject);
begin
  with ExportFilter as TRMRTFExport do
  begin
    chkExportFrames.Checked := ExportFrames;
    chkExportImages.Checked := ExportImages;
    cbImageFormat.ItemIndex := cbImageFormat.Items.IndexOfObject(TObject(Ord(ExportImageFormat)));
    if cbImageFormat.ItemIndex < 0 then cbImageFormat.ItemIndex := 0;
{$IFDEF JPEG}
		UpDown1.Position := JPEGQuality;
{$ENDIF}
  end;
  chkExportImagesClick(Sender);
end;

procedure TRMRTFExportForm.btnOKClick(Sender: TObject);
begin
  with ExportFilter as TRMRTFExport do
  begin
    ExportFrames := chkExportFrames.Checked;
    ExportImages := chkExportImages.Checked;
    ExportImageFormat := TRMEFImageFormat(cbImageFormat.Items.Objects[cbImageFormat.ItemIndex]);
{$IFDEF JPEG}
    JPEGQuality := StrToInt(edJPEGQuality.Text);
{$ENDIF}
  end;
end;

procedure TRMRTFExportForm.cbImageFormatChange(Sender: TObject);
begin
  if (chkExportImages.Checked and
    (cbImageFormat.Text = ImageFormats[ifJPG])) then
  begin
    lblJPEGQuality.Enabled := True;
    edJPEGQuality.Enabled := True;
    edJPEGQuality.Color := clWindow;
  end
  else
  begin
    lblJPEGQuality.Enabled := False;
    edJPEGQuality.Enabled := False;
    edJPEGQuality.Color := clInactiveBorder;
  end;
end;

procedure TRMRTFExportForm.edJPEGQualityKeyPress(Sender: TObject;
  var Key: Char);
begin
  if not (Key in ['0'..'9', #8]) then
    Key := #0;
end;

end.