rm_e_rtf.pas

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

unit RM_e_rtf;

interface

{$I RM.INC}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, RM_Class, RM_e_main
{$IFDEF JPEG}, Jpeg{$ENDIF};

const
  // We define a quick lookup table of the RTF font family control
  // words.  Windows only supports items 0-5, the last two are defined
  // by Microsoft but are not used in the LOGFONT structure
  QRRTFFontFamily: array[0..7] of string =
   ('\fnil ', '\froman ', '\fswiss ', '\fmodern ', '\fscript ', '\fdecor ',
    '\ftech ', '\fbidi ');

type
  TColorByte = (cbRed, cbGreen, cbBlue);

 { TRMRTFExport }
  TRMRTFExport = class(TRMMainExportFilter)
  private
    FTempStream: TMemoryStream; // Temp Memory stream
    FFontTable: TStringList; // Font Table list
    FColorTable: TStringList; // Color Table List
    FGraphicDataInBinary: Boolean;
    function MakeFontTable: string;
    function MakeColorTable: string;
    function GetColorNumInColorTbl(AColor: TColor): Integer;
    function ColorBGRToRGB(AColor: TColor): string;
    function WriteHeader: string;
    function HexToInt(HexCode: string): string;
    function GetNativePos(X: Extended): Extended;
    function NumToStr(N: Extended): string;
    function GetNativeText(const Text: string): string;
    procedure WriteToTempStream(AText: string);
    procedure SetExportImageFormat(const Value: TRMEFImageFormat);
  public
    constructor Create(AOwner: TComponent); override;
    procedure OnBeginDoc; override;
    procedure OnEndDoc; override;
    procedure OnBeginPage; override;
    procedure OnEndPage; override;
    function ShowModal: Word; override;
  published
    property ExportImageFormat: TRMEFImageFormat read FExportImageFormat write SetExportImageFormat;
    property GraphicDataInBinary: Boolean read FGraphicDataInBinary write FGraphicDataInBinary default False;
  end;

  { TRMRFTExportForm }
  TRMRTFExportForm = class(TForm)
    gbExportOptions: TGroupBox;
    chkExportFrames: TCheckBox;
    gbExportImages: TGroupBox;
    lblExportImageFormat: TLabel;
    cbImageFormat: TComboBox;
    btnOK: TButton;
    btnCancel: TButton;
    lblJPEGQuality: TLabel;
    chkExportImages: TCheckBox;
    edJPEGQuality: TEdit;
    UpDown1: TUpDown;
    procedure FormCreate(Sender: TObject);
    procedure chkExportImagesClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btnOKClick(Sender: TObject);
    procedure cbImageFormatChange(Sender: TObject);
    procedure edJPEGQualityKeyPress(Sender: TObject; var Key: Char);
  private
    FExportFilter: TRMExportFilter;
    procedure Localize;
  protected
  public
    property ExportFilter: TRMExportFilter read FExportFilter write FExportFilter;
  end;

implementation

{$R *.DFM}

uses Printers, RM_CmpReg, RM_Const, RM_Utils;

const
  CRLF = #13#10;
  cPointToTwip = 20; //  multiply by
  CFRUnitsPerInch = 254; // divide by
  CInchToPoint = 72; // multiply by
  CmmToPixel = 0.36; // divide by

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMRTFExport}

constructor TRMRTFExport.Create;
begin
  inherited;
  FGraphicDataInBinary := False;
  RMRegisterExportFilter(Self, RMLoadStr(SRTFFile) + ' (*.rtf)', '*.rtf');
end;

procedure TRMRTFExport.SetExportImageFormat(const Value: TRMEFImageFormat);
begin
  if (Value in [ifJPG, ifBMP]) then
    FExportImageFormat := Value;
end;

procedure TRMRTFExport.OnBeginDoc;
begin
  inherited;
  FTempStream := TMemoryStream.Create;
  FFontTable := TStringList.Create;
  FColorTable := TStringList.Create;
end;

procedure TRMRTFExport.OnEndDoc;
var
  S: string;
begin
  try
    WriteHeader;
    Stream.CopyFrom(FTempStream, 0);
    S := '}';
    Stream.Write(Pointer(S)^, Length(S));
  finally
    FFontTable.Free;
    FColorTable.Free;
    FTempStream.Free;
  end;
  inherited;
end;

procedure TRMRTFExport.OnBeginPage;
{var
  S: string; //waw delete }
begin
  inherited;    {   //waw delete
  S := '{' + CRLF;
  if FPageNo >= 0 then
    WriteToTempStream(S);       }
end;

const
  Bold: array[Boolean] of string = ('', ' \b');
  Italic: array[Boolean] of string = ('', ' \i');
  StrikeOut: array[Boolean] of string = ('', ' \strike');
  UnderLine: array[Boolean] of string = ('', ' \ul');
  Bold0: array[Boolean] of string = ('', ' \b0');
  Italic0: array[Boolean] of string = ('', ' \i0');
  StrikeOut0: array[Boolean] of string = ('', ' \strike0');
  UnderLine0: array[Boolean] of string = ('', ' \ul0');
  PictureType: array[TRMEFImageFormat] of string =
  ('\wmetafile8', '\jpegblip', '\wmetafile8');

procedure TRMRTFExport.OnEndPage;
var
  EncodedText, TextAlignment: string;
  FTextAttribSetStr, FTextAttribResetStr: string;
  S, STemp, SText, ABorderInfo, ShadeAttrib, LineAttrib, SFrame: string;
  s0, s1: string;
  Fn, I, j, n, n1: Integer;
  DataRec: PRMEFDataRec;
  ALeft, AWidth, ATop, AHeight: Extended;
  bArr: array[0..1023] of Byte;
  AStream: TStream;
  DrawTop, DrawBottom, DrawRight, DrawLeft: Boolean;
  liFlag: Boolean;

  function GetBinHex(S: string): string;
  var
    I: Integer;
  begin
    Result := '';
    for I := 1 to Length(S) do
      Result := Result + IntToHex(Ord(S[I]), 2);
  end;

  function ExtractColorValue(AColorByte: TColorByte; AColor: TColor): string;
  begin
    Result := HexToInt(Copy(ColorBGRToRGB(AColor), Ord(AColorByte) * 2 + 1, 2));
  end;

  function EncodeLine(Left, Top, Right, Bottom: Extended): string;
  begin
    Result := '{\*\do\dobxpage\dobypage\dpline' +
      '\dpptx0\dppty0' +
      '\dpptx' + NumToStr(Right - Left) +
      '\dppty' + NumToStr(Bottom - Top) +
      '\dpx' + NumToStr(Left) +
      '\dpy' + NumToStr(Top) +
      '\dpxsize' + NumToStr(Right - Left + 1) +
      '\dpysize' + NumToStr(Bottom - Top + 1) +
      '\dplinesolid' + LineAttrib;
  end;

  function EncodeFrame: string;
  var
    ARight, ABottom: Extended;
    Str: string;
  begin
    Result := '';
    ARight := ALeft + AWidth;
    ABottom := ATop + AHeight;

    Str := CRLF + '{\*\do\dobxpage\dobypage\dprect' +
      '\dpx' + NumToStr(ALeft) +
      '\dpy' + NumToStr(ATop) +
      '\dpxsize' + NumToStr(AWidth) +
      '\dpysize' + NumToStr(AHeight);

    if (DataRec^.FrameInfo.FrameTyp = efftAll) or
      (DataRec^.FrameInfo.FillColor <> clNone) then
    begin
      if (DataRec^.FrameInfo.FrameTyp = efftAll) then
        Result := '\dplinesolid' + LineAttrib
      else
        Result := '\dplinehollow';
      Result := Str + Result + ShadeAttrib + '}' + CRLF;
    end;

    if (DataRec^.FrameInfo.FrameTyp <> efftAll) then
    begin
      if DrawTop then
        Result := Result + EncodeLine(ALeft, ATop, ARight, ATop) + '}' + CRLF;
      if DrawRight then
        Result := Result + EncodeLine(ARight, ATop, ARight, ABottom) + '}' + CRLF;
      if DrawBottom then
        Result := Result + EncodeLine(ALeft, ABottom, ARight, ABottom) + '}' + CRLF;
      if DrawLeft then
        Result := Result + EncodeLine(ALeft, ATop, ALeft, ABottom) + '}' + CRLF;
    end;
    if Result = '' then
      Result := Str + '\dplinehollow }' + CRLF;
  end;

  function GetTextBorderInfo: string;
  var
    Attrib: string;
    FrameWidth: Extended;
  begin
    FrameWidth := GetNativePos(DataRec^.FrameInfo.FrameWidth);
    Result := '';
    Attrib := '';

  // border width, spacing and color
  //  if not DataRec^.Stretched then      //waw delete
      Attrib := '\absh-' + NumToStr(AHeight + 1);
    Attrib := Attrib + '\absw' + NumToStr(AWidth + 1 - 100) +
      '\brdrs\brdrw' + NumToStr(FrameWidth) +
      '\brdrcf' + IntToStr(GetColorNumInColorTbl(DataRec^.FrameInfo.FrameColor));

    if DrawTop and DrawRight and DrawBottom and DrawLeft then
      Result := Result + '\box' + Attrib
    else
    begin
      if DrawTop then
        Result := Result + '\brdrt' + Attrib;
      if DrawRight then
        Result := Result + '\brdrr' + Attrib;
      if DrawBottom then
        Result := Result + '\brdrb' + Attrib;
      if DrawLeft then
        Result := Result + '\brdrl' + Attrib;
    end;
  end;

begin
  S := '{' + CRLF;          //waw
  WriteToTempStream(S);     //waw
  for I := 0 to FDataList.Count - 1 do
  begin
    Application.ProcessMessages;

    DataRec := PRMEFDataRec(FDataList[I]);
    ALeft := GetNativePos(DataRec^.X);
    if ExportFrames then
      AWidth := GetNativePos(DataRec^.dx + 1)
    else
      AWidth := GetNativePos(DataRec^.dx);
    ATop := GetNativePos(DataRec^.Y);
    if ExportFrames then
      AHeight := GetNativePos(DataRec^.dy + 1)
    else
      AHeight := GetNativePos(DataRec^.dy);

    S := '';
    STemp := '';
    SFrame := '';
    ABorderInfo := '';
    EncodedText := '';

  // Right Frame
    DrawRight := DataRec^.FrameInfo.FrameTyp in [efftRight, efftRightBottom,
      efftLeftRight, efftLeftRightBottom, efftRightTop, efftRightTopBottom,
      efftLeftRightTop, efftAll];

  // Left Frame
    DrawLeft := DataRec^.FrameInfo.FrameTyp in [efftLeft, efftLeftRight,
      efftLeftBottom, efftLeftRightBottom, efftLeftTop, efftLeftRightTop,
      efftLeftTopBottom, efftAll];

  // Top Frame
    DrawTop := DataRec^.FrameInfo.FrameTyp in [efftTop, efftRightTop, efftTopBottom,
      efftRightTopBottom, efftLeftTop, efftLeftRightTop,
      efftLeftTopBottom, efftAll];

  // Bottom Frame
    DrawBottom := DataRec^.FrameInfo.FrameTyp in [efftBottom, efftRightBottom,
      efftLeftBottom, efftLeftRightBottom, efftTopBottom, efftRightTopBottom,
      efftLeftTopBottom, efftAll];

    if ExportImages then // Export Image
    begin
      liFlag := (DataRec^.ViewClassName = TRMMemoView.ClassName) or (DataRec^.ViewClassName = TRMCalcMemoView.ClassName);
      if (not liFlag or DataRec^.VerticalText) and (DataRec^.ViewClassName <> TRMLineView.ClassName) then
      begin
        if ExportImageFormat <> ifBMP then
          AStream := GetBitmapAsJpgGifStream(Datarec^.Bitmap,
            ExportImageFormat{$IFDEF JPEG}, JPEGQuality{$ENDIF})
        else
        begin
          AStream := TMemoryStream.Create;
          DataRec^.Bitmap.SaveToStream(AStream);
        end;

        try
          with AStream as TMemoryStream do
          begin
            Position := 0;
            SetLength(S, Size);
            Read(S[1], Size);
          end;

          STemp := '\par\pard\pvpg\phpg' +
            '\posx' + NumToStr(ALeft) +
            '\posy' + NumToStr(ATop) +
            '{\pict' + PictureType[TRMEFImageFormat(ExportImageFormat)] +
            '\picw' + NumToStr(DataRec^.dx * 26.46875) +
            '\pich' + NumToStr(DataRec^.dy * 26.46875) +
            '\picbmp\picbpp4';
          STemp := STemp + CRLF;
          WriteToTempStream(STemp);

          if ExportImageFormat = ifBMP then
          begin
            AStream.Position := 0;

            AStream.Read(n, 2);
            AStream.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(DataRec^.Bitmap.Height, 4);
            s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
            s0 := IntToHex(DataRec^.Bitmap.Width, 4);