home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kolekce / d6 / FRCLX.ZIP / SOURCE / FR_E_HTM.pas < prev    next >
Pascal/Delphi Source File  |  2001-07-06  |  7KB  |  287 lines
  1.  
  2. {******************************************}
  3. {                                          }
  4. {           FastReport CLX v2.4            }
  5. {            HTM export filter             }
  6. {                                          }
  7. { Copyright (c) 1998-2001 by Tzyganenko A. }
  8. {                                          }
  9. {******************************************}
  10.  
  11. unit FR_E_HTM;
  12.  
  13. interface
  14.  
  15. {$I FR.inc}
  16.  
  17. uses
  18.   SysUtils, Types, Classes, QGraphics, QForms, QStdCtrls,
  19.   FR_Class, FR_E_TXT, QControls;
  20.  
  21. type
  22.   TfrHTMExport = class(TfrTextExport)
  23.   private
  24.     FExportPictures: Boolean;
  25.     DataList: TList;
  26.     ImgNumber: Integer;
  27.   public
  28.     constructor Create(AOwner: TComponent); override;
  29.     function ShowModal: Word; override;
  30.     procedure OnEndPage; override;
  31.     procedure OnData(x, y: Integer; View: TfrView); override;
  32.     procedure OnBeginDoc; override;
  33.     procedure OnEndDoc; override;
  34.   published
  35.     property ExportPictures: Boolean read FExportPictures write FExportPictures default False;
  36.   end;
  37.  
  38.   TfrHTMExportForm = class(TForm)
  39.     GroupBox1: TGroupBox;
  40.     Label1: TLabel;
  41.     Button1: TButton;
  42.     Button2: TButton;
  43.     E2: TEdit;
  44.     CB2: TCheckBox;
  45.     Label3: TLabel;
  46.     CB1: TCheckBox;
  47.     procedure FormCreate(Sender: TObject);
  48.   private
  49.     { Private declarations }
  50.     procedure Localize;
  51.   public
  52.     { Public declarations }
  53.   end;
  54.  
  55.  
  56. implementation
  57.  
  58. uses FR_Utils, FR_Const {$IFDEF JPEG}, JPEG {$ENDIF};
  59.  
  60. {$R *.xfm}
  61.  
  62.  
  63. { TfrHTMExport }
  64.  
  65. constructor TfrHTMExport.Create(AOwner: TComponent);
  66. begin
  67.   inherited Create(AOwner);
  68.   frRegisterExportFilter(Self, (SHTMFile) + ' (*.htm)', '*.htm');
  69.   ShowDialog := True;
  70.   ScaleY := 1;
  71.   KillEmptyLines := True;
  72.   ExportPictures := False;
  73. end;
  74.  
  75. procedure TfrHTMExport.OnBeginDoc;
  76. var
  77.   s: String;
  78. begin
  79.   DataList := TList.Create;
  80.   s := '<HTML>'#13#10'<Body bgColor="#FFFFFF">'#13#10'<Table>'#13#10;
  81.   Stream.Write(s[1], Length(s));
  82.   ImgNumber := 0;
  83. end;
  84.  
  85. procedure TfrHTMExport.OnEndDoc;
  86. var
  87.   s: String;
  88. begin
  89.   s := '</Table>'#13#10'</Body>'#13#10'</HTML>'#13#10;
  90.   Stream.Write(s[1], Length(s));
  91.   DataList.Free;
  92. end;
  93.  
  94. function TfrHTMExport.ShowModal: Word;
  95. begin
  96.   if not ShowDialog then
  97.     Result := mrOk
  98.   else with TfrHTMExportForm.Create(nil) do
  99.   begin
  100.     CB1.Checked := KillEmptyLines;
  101.     CB2.Checked := ExportPictures;
  102.     E2.Text := FloatToStr(ScaleY);
  103.     Result := ShowModal;
  104.     try
  105.       ScaleY := frStrToFloat(E2.Text);
  106.     except
  107.       ScaleY := 1;
  108.     end;
  109.     KillEmptyLines := CB1.Checked;
  110.     ExportPictures := CB2.Checked;
  111.     Free;
  112.   end;
  113. end;
  114.  
  115. procedure TfrHTMExport.OnEndPage;
  116. var
  117.   i, n: Integer;
  118.   p: PfrTextRec;
  119.   s, s1, s2: String;
  120.   Str: TStream;
  121.   Pict: TPicture;
  122.   Graphic: TGraphic;
  123.   x, y, dx, dy: Integer;
  124.   b: Byte;
  125.   IsEmpty: Boolean;
  126.  
  127.   function GetHTMLFontSize(Size: Integer): String;
  128.   begin
  129.     case Size of
  130.       6, 7: Result := '1';
  131.       8, 9: Result := '2';
  132.       14..17: Result := '4';
  133.       18..23: Result := '5';
  134.       24..35: Result := '6'
  135.     else
  136.       Result := '7';
  137.     end;
  138.   end;
  139.  
  140.   function GetHTMLFontStyle(Style: Integer): String;
  141.   begin
  142.     Result := '';
  143.     if (Style and $1) <> 0 then Result := '<i>';
  144.     if (Style and $2) <> 0 then Result := Result + '<b>';
  145.     if (Style and $4) <> 0 then Result := Result + '<u>';
  146.   end;
  147.  
  148. begin
  149.   if ExportPictures then
  150.     for i := 0 to DataList.Count - 1 do
  151.     begin
  152.       Str := TStream(DataList[i]);
  153.       Str.Position := 0;
  154.       Pict := TPicture.Create;
  155.       Str.Read(x, 4);
  156.       Str.Read(y, 4);
  157.       Str.Read(dx, 4);
  158.       Str.Read(dy, 4);
  159.       Str.Read(b, 1);
  160.  
  161.       Graphic := TBitmap.Create;
  162.       s := 'htm' + IntToStr(ImgNumber) + '.bmp';
  163.       if b = 1 then
  164.       begin
  165. {$IFDEF JPEG}
  166.         Graphic.Free;
  167.         Graphic := TJPEGImage.Create;
  168.         s := 'htm' + IntToStr(ImgNumber) + '.jpg';
  169. {$ENDIF}
  170.       end;
  171.       Pict.Graphic := Graphic;
  172.       Graphic.Free;
  173.       Pict.Graphic.LoadFromStream(Str);
  174.       Pict.Graphic.SaveToFile(ExtractFilePath(FileName) + s);
  175.  
  176.       GetMem(p, SizeOf(TfrTextRec));
  177.       FillChar(p^, SizeOf(TfrTextRec), 0);
  178.       p^.X := x;
  179.       p^.Text := s;
  180.       p^.DrawRect := Rect(x, y, dx, dy);
  181.       p^.FrameTyp := -1;
  182.       InsertTextRec(p, Round(y / (14 / ScaleY)));
  183.  
  184.       Pict.Free;
  185.       Str.Free;
  186.       Inc(ImgNumber);
  187.     end;
  188.   DataList.Clear;
  189.  
  190.   n := Lines.Count - 1;
  191.   while n >= 0 do
  192.   begin
  193.     if Lines[n] <> nil then break;
  194.     Dec(n);
  195.   end;
  196.  
  197.   for i := 0 to n do
  198.   begin
  199.     p := PfrTextRec(Lines[i]);
  200.     s := '<tr>';
  201.     IsEmpty := True;
  202.     while p <> nil do
  203.     begin
  204.       IsEmpty := False;
  205.       s1 := ''; s2 := '';
  206.       if p^.FrameTyp = -1 then
  207.       begin
  208.         s1 := '<img src="' + p^.Text + '" width="' +
  209.           IntToStr(p^.DrawRect.Right) + '" height="' +
  210.           IntToStr(p^.DrawRect.Bottom) + '">';
  211.         s := s + '<td>' + s1 + '</td>';
  212.       end
  213.       else
  214.       begin
  215.         if (p^.FontColor = clWhite) or (p^.FontColor = clNone) then
  216.           p^.FontColor := clBlack;
  217.         if p^.FontColor <> clBlack then
  218.         begin
  219.           s1 := IntToHex(p^.FontColor, 6);
  220.           s1 := 'Color="#' + Copy(s1, 5, 2) + Copy(s1, 3, 2) +
  221.             Copy(s1, 1, 2) + '"';
  222.         end;
  223.         if not (p^.FontSize in [10..13]) then
  224.           s1 := s1 + ' Size=' + GetHTMLFontSize(p^.FontSize);
  225.         if p^.FontStyle <> 0 then
  226.           s2 := GetHTMLFontStyle(p^.FontStyle);
  227.         if s1 <> '' then s1 := '<Font ' + s1 + '>';
  228.         s := s + '<td>' + s1 + s2 + p^.Text + '</td>';
  229.       end;
  230.       p := p^.Next;
  231.     end;
  232.     if not KillEmptyLines or not IsEmpty then
  233.     begin
  234.       s := s + '</tr>'#13#10;
  235.       Stream.Write(s[1], Length(s));
  236.     end;
  237.   end;
  238. end;
  239.  
  240. procedure TfrHTMExport.OnData(x, y: Integer; View: TfrView);
  241. var
  242.   Str: TStream;
  243.   b: Byte;
  244.   Graphic: TGraphic;
  245. begin
  246.   if ExportPictures then
  247.     if View is TfrPictureView then
  248.     begin
  249.       Graphic := TfrPictureView(View).Picture.Graphic;
  250.       if not ((Graphic = nil) or Graphic.Empty) then
  251.       begin
  252.         Str := TMemoryStream.Create;
  253.         Str.Write(x, 4);
  254.         Str.Write(y, 4);
  255.         Str.Write(View.dx, 4);
  256.         Str.Write(View.dy, 4);
  257.         b := 0;
  258. {$IFDEF JPEG}
  259.         if Graphic is TJPEGImage then
  260.           b := 1;
  261. {$ENDIF}
  262.         Str.Write(b, 1);
  263.         Graphic.SaveToStream(Str);
  264.         DataList.Add(Str);
  265.       end;
  266.     end;
  267. end;
  268.  
  269.  
  270. procedure TfrHTMExportForm.Localize;
  271. begin
  272.   Caption := S54830;
  273.   CB1.Caption := S54801;
  274.   CB2.Caption := S54821;
  275.   Label1.Caption := S54806;
  276.   Button1.Caption := (SOk);
  277.   Button2.Caption := (SCancel);
  278. end;
  279.  
  280. procedure TfrHTMExportForm.FormCreate(Sender: TObject);
  281. begin
  282.   Localize;
  283. end;
  284.  
  285.  
  286. end.
  287.