rm_e_rtf.pas

进销存·完整的·有数据库的·非常完整·只得参考

            s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) +
              '05000000090200000000050000000102ffffff000400000007010300' + s1 +
              '430f2000cc000000';
            s0 := IntToHex(DataRec^.Bitmap.Height, 4);
            s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
            s0 := IntToHex(DataRec^.Bitmap.Width, 4);
            s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) + '00000000';
            s0 := IntToHex(DataRec^.Bitmap.Height, 4);
            s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
            s0 := IntToHex(DataRec^.Bitmap.Width, 4);
            s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) + '00000000' + CRLF;
            WriteToTempStream(s);

            AStream.Read(bArr[0], 8);
            n1 := 0; s := '';
            repeat
              n := AStream.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;
                  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
        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;
      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;

      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.ReportInfo.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
  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] + ';}';  //waw
    Result := Result + '{\f' + IntToStr(I) +
      QRRTFFontFamily[Integer(FFontTable.Objects[I])] + 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
	Result := x * (11907 / 794);
//  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 ');      //waw
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));

  RMSetStrProp(Self, 'Caption', rmRes + 1820);
  RMSetStrProp(chkExportFrames, 'Caption', rmRes + 1803);
  RMSetStrProp(chkExportImages, 'Caption', rmRes + 1821);
  RMSetStrProp(lblExportImageFormat, 'Caption', rmRes + 1816);
  RMSetStrProp(lblJPEGQuality, 'Caption', 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.