home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kolekce / d6 / FRCLX.ZIP / SOURCE / FR_E_RTF.pas < prev    next >
Pascal/Delphi Source File  |  2001-07-06  |  11KB  |  441 lines
  1.  
  2. {******************************************}
  3. {                                          }
  4. {           FastReport CLX v2.4            }
  5. {            RTF export filter             }
  6. {                                          }
  7. { Copyright (c) 1998-2001 by Tzyganenko A. }
  8. {                                          }
  9. {******************************************}
  10.  
  11. unit FR_E_RTF;
  12.  
  13. interface
  14.  
  15. {$I FR.inc}
  16.  
  17. uses
  18.   SysUtils, Types, Classes, QGraphics, QForms, QStdCtrls, QComCtrls,
  19.   FR_Class, FR_E_TXT, QControls;
  20.  
  21. type
  22.   TfrRTFExport = class(TfrTextExport)
  23.   private
  24.     FExportBitmaps, FConvertToTable: Boolean;
  25.     TempStream: TStream;
  26.     FontTable, ColorTable: TStringList;
  27.     DataList: TList;
  28.     NewPage: Boolean;
  29.   public
  30.     constructor Create(AOwner: TComponent); override;
  31.     function ShowModal: Word; override;
  32.     procedure OnEndPage; override;
  33.     procedure OnData(x, y: Integer; View: TfrView); override;
  34.     procedure OnBeginDoc; override;
  35.     procedure OnEndDoc; override;
  36.   published
  37.     property ExportBitmaps: Boolean read FExportBitmaps write FExportBitmaps default False;
  38.     property ConvertToTable: Boolean read FConvertToTable write FConvertToTable default False;
  39.   end;
  40.  
  41.   TfrRTFExportForm = class(TForm)
  42.     GroupBox1: TGroupBox;
  43.     CB1: TCheckBox;
  44.     Label1: TLabel;
  45.     E1: TEdit;
  46.     Button1: TButton;
  47.     Button2: TButton;
  48.     CB5: TCheckBox;
  49.     Label2: TLabel;
  50.     Label3: TLabel;
  51.     E2: TEdit;
  52.     CB2: TCheckBox;
  53.     CB3: TCheckBox;
  54.     procedure FormCreate(Sender: TObject);
  55.   private
  56.     { Private declarations }
  57.     procedure Localize;
  58.   public
  59.     { Public declarations }
  60.   end;
  61.  
  62.  
  63. implementation
  64.  
  65. uses FR_Const, FR_Utils;
  66.  
  67. {$R *.xfm}
  68.  
  69.  
  70. { TfrRTFExport }
  71.  
  72. constructor TfrRTFExport.Create(AOwner: TComponent);
  73. begin
  74.   inherited Create(AOwner);
  75.   frRegisterExportFilter(Self, (SRTFFile) + ' (*.rtf)', '*.rtf');
  76.   ShowDialog := True;
  77.   ScaleX := 1;
  78.   ScaleY := 1;
  79.   KillEmptyLines := True;
  80.   ExportBitmaps := False;
  81.   ConvertToTable := False;
  82.   PageBreaks := True;
  83.   ScaleX := 1.3;
  84. end;
  85.  
  86. procedure TfrRTFExport.OnBeginDoc;
  87. var
  88.   s: String;
  89. begin
  90.   FontTable := TStringList.Create;
  91.   ColorTable := TStringList.Create;
  92.   DataList := TList.Create;
  93.   TempStream := TMemoryStream.Create;
  94.   s := '{\rtf1\ansi' + #13#10 + '\margl600\margr600\margt600\margb600' + #13#10;
  95.   Stream.Write(s[1], Length(s));
  96. end;
  97.  
  98. procedure TfrRTFExport.OnEndDoc;
  99. var
  100.   i, c: Integer;
  101.   s, s1: String;
  102.  
  103.   function GetRValue(rgb: DWORD): Byte;
  104.   begin
  105.     Result := Byte(rgb);
  106.   end;
  107.  
  108.   function GetGValue(rgb: DWORD): Byte;
  109.   begin
  110.     Result := Byte(rgb shr 8);
  111.   end;
  112.  
  113.   function GetBValue(rgb: DWORD): Byte;
  114.   begin
  115.     Result := Byte(rgb shr 16);
  116.   end;
  117.  
  118. begin
  119.   s := '\par}';
  120.   TempStream.Write(s[1], Length(s));
  121.   s := '{\fonttbl';
  122.   for i := 0 to FontTable.Count - 1 do
  123.   begin
  124.     s1 := '{\f' + IntToStr(i) + ' ' + FontTable[i] + '}';
  125.     if Length(s + s1) < 255 then
  126.       s := s + s1
  127.     else
  128.     begin
  129.       s := s + #13#10;
  130.       Stream.Write(s[1], Length(s));
  131.       s := s1;
  132.     end;
  133.   end;
  134.   s := s + '}' + #13#10;
  135.   Stream.Write(s[1], Length(s));
  136.  
  137.   s := '{\colortbl;';
  138.   for i := 0 to ColorTable.Count - 1 do
  139.   begin
  140.     c := StrToInt(ColorTable[i]);
  141.     s1 := '\red' + IntToStr(GetRValue(c)) +
  142.           '\green' + IntToStr(GetGValue(c)) +
  143.           '\blue' + IntToStr(GetBValue(c)) + ';';
  144.     if Length(s + s1) < 255 then
  145.       s := s + s1
  146.     else
  147.     begin
  148.       s := s + #13#10;
  149.       Stream.Write(s[1], Length(s));
  150.       s := s1;
  151.     end;
  152.   end;
  153.   s := s + '}' + #13#10;
  154.   Stream.Write(s[1], Length(s));
  155.  
  156.   Stream.CopyFrom(TempStream, 0);
  157.   TempStream.Free;
  158.   FontTable.Free;
  159.   ColorTable.Free;
  160.   DataList.Free;
  161. end;
  162.  
  163. function TfrRTFExport.ShowModal: Word;
  164. begin
  165.   if not ShowDialog then
  166.     Result := mrOk
  167.   else with TfrRTFExportForm.Create(nil) do
  168.   begin
  169.     CB1.Checked := KillEmptyLines;
  170.     CB2.Checked := ExportBitmaps;
  171.     CB3.Checked := ConvertToTable;
  172.     CB5.Checked := PageBreaks;
  173.     E1.Text := FloatToStr(ScaleX);
  174.     E2.Text := FloatToStr(ScaleY);
  175.  
  176.     Result := ShowModal;
  177.     try
  178.       ScaleX := frStrToFloat(E1.Text);
  179.     except
  180.       ScaleX := 1;
  181.     end;
  182.     try
  183.       ScaleY := frStrToFloat(E2.Text);
  184.     except
  185.       ScaleY := 1;
  186.     end;
  187.     KillEmptyLines := CB1.Checked;
  188.     ExportBitmaps := CB2.Checked;
  189.     ConvertToTable := CB3.Checked;
  190.     PageBreaks := CB5.Checked;
  191.     Free;
  192.   end;
  193. end;
  194.  
  195. procedure TfrRTFExport.OnEndPage;
  196. var
  197.   i, j, n, n1, x, x1, y, dx, dy: Integer;
  198.   p: PfrTextRec;
  199.   s0, s, s1: String;
  200.   fSize, fStyle, fColor: Integer;
  201.   fName: String;
  202.   Str: TStream;
  203.   bArr: Array[0..1023] of Byte;
  204.   IsEmpty: Boolean;
  205.  
  206.   function GetFontStyle(f: Integer): String;
  207.   begin
  208.     Result := '';
  209.     if (f and $1) <> 0 then Result := '\i';
  210.     if (f and $2) <> 0 then Result := Result + '\b';
  211.     if (f and $4) <> 0 then Result := Result + '\u';
  212.   end;
  213.  
  214.   function GetFontColor(f: String): String;
  215.   var
  216.     i: Integer;
  217.   begin
  218.     i := ColorTable.IndexOf(f);
  219.     if i <> -1 then
  220.       Result := IntToStr(i + 1)
  221.     else
  222.     begin
  223.       ColorTable.Add(f);
  224.       Result := IntToStr(ColorTable.Count);
  225.     end;
  226.   end;
  227.  
  228.   function GetFontName(f: String): String;
  229.   var
  230.     i: Integer;
  231.   begin
  232.     i := FontTable.IndexOf(f);
  233.     if i <> -1 then
  234.       Result := IntToStr(i)
  235.     else
  236.     begin
  237.       FontTable.Add(f);
  238.       Result := IntToStr(FontTable.Count - 1);
  239.     end;
  240.   end;
  241.  
  242. begin
  243.   if NewPage and PageBreaks then
  244.   begin
  245.     s := '\page' + #13#10;
  246.     TempStream.Write(s[1], Length(s));
  247.   end;
  248.  
  249.   if ExportBitmaps then
  250.     for i := 0 to DataList.Count - 1 do
  251.     begin
  252.       Str := TStream(DataList[i]);
  253.       Str.Position := 0;
  254.       Str.Read(x, 4);
  255.       Str.Read(y, 4);
  256.       Str.Read(dx, 4);
  257.       Str.Read(dy, 4);
  258.       s := '\pard\phmrg\posx' + IntToStr(Round(x / (1.3 / ScaleX) * 20)) +
  259.            '\posy' + IntToStr(Round(y * 20 / 1.3)) +
  260.            '\absh' + IntToStr(dy * 20) +
  261.            '\absw' + IntToStr(dx * 20) +
  262.            '{\pict\wmetafile8\picw' + IntToStr(Round(dx * 26.46875)) +
  263.            '\pich' + IntToStr(Round(dy * 26.46875)) + ' \picbmp\picbpp4' + #13#10;
  264.       TempStream.Write(s[1], Length(s));
  265.   // shit begins
  266.       Str.Read(dx, 4);
  267.       Str.Read(dy, 4);
  268.       Str.Read(n, 2);
  269.       Str.Read(n, 4);
  270.       n := n div 2 + 7;
  271.       s0 := IntToHex(n + $24, 8);
  272.       s := '010009000003' + Copy(s0, 7, 2) + Copy(s0, 5, 2) +
  273.            Copy(s0, 3, 2) + Copy(s0, 1, 2) + '0000';
  274.       s0 := IntToHex(n, 8);
  275.       s1 := Copy(s0, 7, 2) + Copy(s0, 5, 2) + Copy(s0, 3, 2) + Copy(s0, 1, 2);
  276.       s := s + s1 + '0000050000000b0200000000050000000c02';
  277.       s0 := IntToHex(dy, 4);
  278.       s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
  279.       s0 := IntToHex(dx, 4);
  280.       s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) +
  281.            '05000000090200000000050000000102ffffff000400000007010300' + s1 +
  282.            '430f2000cc000000';
  283.       s0 := IntToHex(dy, 4);
  284.       s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
  285.       s0 := IntToHex(dx, 4);
  286.       s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) + '00000000';
  287.       s0 := IntToHex(dy, 4);
  288.       s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
  289.       s0 := IntToHex(dx, 4);
  290.       s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) + '00000000' + #13#10;
  291.       TempStream.Write(s[1], Length(s));
  292.   // shit ends
  293.  
  294.       Str.Read(bArr[0], 8);
  295.       n1 := 0; s := '';
  296.       repeat
  297.         n := Str.Read(bArr[0], 1024);
  298.         for j := 0 to n - 1 do
  299.         begin
  300.           s := s + IntToHex(bArr[j], 2);
  301.           Inc(n1);
  302.           if n1 > 63 then
  303.           begin
  304.             n1 := 0;
  305.             s := s + #13#10;
  306.             TempStream.Write(s[1], Length(s));
  307.             s := '';
  308.           end;
  309.         end;
  310.       until n < 1024;
  311.       Str.Free;
  312.       if n1 <> 0 then
  313.         TempStream.Write(s[1], Length(s));
  314.  
  315.       s := '030000000000}\par' + #13#10;
  316.       TempStream.Write(s[1], Length(s));
  317.     end;
  318.  
  319.   n := Lines.Count - 1;
  320.   while n >= 0 do
  321.   begin
  322.     if Lines[n] <> nil then break;
  323.     Dec(n);
  324.   end;
  325.  
  326.   for i := 0 to n do
  327.   begin
  328.     p := PfrTextRec(Lines[i]);
  329.     s := '';
  330.     fSize := -1; fStyle := -1; fColor := -1; fName := '';
  331.     if ConvertToTable then
  332.       s0 := '\trowd \trgaph108' else
  333.       s0 := '\pard';
  334.     IsEmpty := True;
  335.     x1 := 0;
  336.  
  337.     while p <> nil do
  338.     begin
  339.       IsEmpty := False;
  340.       if ConvertToTable then
  341.       begin
  342.         if p <> PfrTextRec(Lines[i]) then
  343.           s0 := s0 + '\cellx' + IntToStr(Round(p^.X / (1.3 / ScaleX) * 20));
  344.       end
  345.       else
  346.         s0 := s0 + '\tx' + IntToStr(Round(p^.X / (1.3 / ScaleX) * 20));
  347.       s1 := '';
  348.       if p^.FontColor = clWhite then
  349.         p^.FontColor := clBlack;
  350.       if (fName <> p^.FontName) or ConvertToTable then
  351.         s1 := '\f' + GetFontName(p^.FontName);
  352.       if (fSize <> p^.FontSize) or ConvertToTable then
  353.         s1 := s1 + '\fs' + IntToStr(p^.FontSize * 2);
  354.       if (fStyle <> p^.FontStyle) or ConvertToTable then
  355.         s1 := s1 + GetFontStyle(p^.FontStyle);
  356.       if (fColor <> p^.FontColor) or ConvertToTable then
  357.         s1 := s1 + '\cf' + GetFontColor(IntToStr(p^.FontColor));
  358.  
  359.       if ConvertToTable then
  360.         s := s + '{' + s1 + ' ' + p^.Text + '}\cell ' else
  361.         s := s + '\tab' + s1 + ' ' + p^.Text;
  362.  
  363.       fSize := p^.FontSize; fStyle := p^.FontStyle;
  364.       fColor := p^.FontColor; fName := p^.FontName;
  365.       x1 := Round(p^.DrawRect.Right / (1.3 / ScaleX) * 20);
  366.       p := p^.Next;
  367.     end;
  368.  
  369.     if not KillEmptyLines or not IsEmpty then
  370.     begin
  371.       p := PfrTextRec(Lines[i]);
  372.       if p <> nil then
  373.         if ConvertToTable then
  374.         begin
  375.           s0 := s0 + '\cellx' + IntToStr(x1) + ' \trleft' +
  376.             IntToStr(Round(p^.X / (1.3 / ScaleX) * 20));
  377.           s := s0 + ' \pard \intbl ' + s + '\pard \intbl \row' + #13#10;
  378.         end
  379.         else
  380.           s := s0 + '{' + s + '\par}' + #13#10;
  381.       if s = '' then
  382.         s := '{\pard \par}' + #13#10;
  383.       TempStream.Write(s[1], Length(s));
  384.     end;
  385.   end;
  386.  
  387.   if ConvertToTable then
  388.   begin
  389.     s := '\pard' + #13#10;
  390.     TempStream.Write(s[1], Length(s));
  391.   end;
  392.   NewPage := True;
  393.   DataList.Clear;
  394. end;
  395.  
  396. procedure TfrRTFExport.OnData(x, y: Integer; View: TfrView);
  397. var
  398.   Str: TStream;
  399.   n: Integer;
  400.   Graphic: TGraphic;
  401. begin
  402.   if View is TfrPictureView then
  403.   begin
  404.     Graphic := TfrPictureView(View).Picture.Graphic;
  405.     if not ((Graphic = nil) or Graphic.Empty) then
  406.     begin
  407.       Str := TMemoryStream.Create;
  408.       Str.Write(x, 4);
  409.       Str.Write(y, 4);
  410.       Str.Write(View.dx, 4);
  411.       Str.Write(View.dy, 4);
  412.       n := Graphic.Width;
  413.       Str.Write(n, 4);
  414.       n := Graphic.Height;
  415.       Str.Write(n, 4);
  416.       Graphic.SaveToStream(Str);
  417.       DataList.Add(Str);
  418.     end;
  419.   end;
  420. end;
  421.  
  422. procedure TfrRTFExportForm.Localize;
  423. begin
  424.   Caption := S54820;
  425.   CB1.Caption := S54801;
  426.   CB2.Caption := S54821;
  427.   CB3.Caption := S54822;
  428.   CB5.Caption := S54805;
  429.   Label1.Caption := S54806;
  430.   Button1.Caption := (SOk);
  431.   Button2.Caption := (SCancel);
  432. end;
  433.  
  434. procedure TfrRTFExportForm.FormCreate(Sender: TObject);
  435. begin
  436.   Localize;
  437. end;
  438.  
  439.  
  440. end.
  441.