{******************************************} { } { FastReport CLX v2.4 } { HTM export filter } { } { Copyright (c) 1998-2001 by Tzyganenko A. } { } {******************************************} unit FR_E_HTM; interface {$I FR.inc} uses SysUtils, Types, Classes, QGraphics, QForms, QStdCtrls, FR_Class, FR_E_TXT, QControls; type TfrHTMExport = class(TfrTextExport) private FExportPictures: Boolean; DataList: TList; ImgNumber: Integer; public constructor Create(AOwner: TComponent); override; function ShowModal: Word; override; procedure OnEndPage; override; procedure OnData(x, y: Integer; View: TfrView); override; procedure OnBeginDoc; override; procedure OnEndDoc; override; published property ExportPictures: Boolean read FExportPictures write FExportPictures default False; end; TfrHTMExportForm = class(TForm) GroupBox1: TGroupBox; Label1: TLabel; Button1: TButton; Button2: TButton; E2: TEdit; CB2: TCheckBox; Label3: TLabel; CB1: TCheckBox; procedure FormCreate(Sender: TObject); private { Private declarations } procedure Localize; public { Public declarations } end; implementation uses FR_Utils, FR_Const {$IFDEF JPEG}, JPEG {$ENDIF}; {$R *.xfm} { TfrHTMExport } constructor TfrHTMExport.Create(AOwner: TComponent); begin inherited Create(AOwner); frRegisterExportFilter(Self, (SHTMFile) + ' (*.htm)', '*.htm'); ShowDialog := True; ScaleY := 1; KillEmptyLines := True; ExportPictures := False; end; procedure TfrHTMExport.OnBeginDoc; var s: String; begin DataList := TList.Create; s := ''#13#10''#13#10''#13#10; Stream.Write(s[1], Length(s)); ImgNumber := 0; end; procedure TfrHTMExport.OnEndDoc; var s: String; begin s := '
'#13#10''#13#10''#13#10; Stream.Write(s[1], Length(s)); DataList.Free; end; function TfrHTMExport.ShowModal: Word; begin if not ShowDialog then Result := mrOk else with TfrHTMExportForm.Create(nil) do begin CB1.Checked := KillEmptyLines; CB2.Checked := ExportPictures; E2.Text := FloatToStr(ScaleY); Result := ShowModal; try ScaleY := frStrToFloat(E2.Text); except ScaleY := 1; end; KillEmptyLines := CB1.Checked; ExportPictures := CB2.Checked; Free; end; end; procedure TfrHTMExport.OnEndPage; var i, n: Integer; p: PfrTextRec; s, s1, s2: String; Str: TStream; Pict: TPicture; Graphic: TGraphic; x, y, dx, dy: Integer; b: Byte; IsEmpty: Boolean; function GetHTMLFontSize(Size: Integer): String; begin case Size of 6, 7: Result := '1'; 8, 9: Result := '2'; 14..17: Result := '4'; 18..23: Result := '5'; 24..35: Result := '6' else Result := '7'; end; end; function GetHTMLFontStyle(Style: Integer): String; begin Result := ''; if (Style and $1) <> 0 then Result := ''; if (Style and $2) <> 0 then Result := Result + ''; if (Style and $4) <> 0 then Result := Result + ''; end; begin if ExportPictures then for i := 0 to DataList.Count - 1 do begin Str := TStream(DataList[i]); Str.Position := 0; Pict := TPicture.Create; Str.Read(x, 4); Str.Read(y, 4); Str.Read(dx, 4); Str.Read(dy, 4); Str.Read(b, 1); Graphic := TBitmap.Create; s := 'htm' + IntToStr(ImgNumber) + '.bmp'; if b = 1 then begin {$IFDEF JPEG} Graphic.Free; Graphic := TJPEGImage.Create; s := 'htm' + IntToStr(ImgNumber) + '.jpg'; {$ENDIF} end; Pict.Graphic := Graphic; Graphic.Free; Pict.Graphic.LoadFromStream(Str); Pict.Graphic.SaveToFile(ExtractFilePath(FileName) + s); GetMem(p, SizeOf(TfrTextRec)); FillChar(p^, SizeOf(TfrTextRec), 0); p^.X := x; p^.Text := s; p^.DrawRect := Rect(x, y, dx, dy); p^.FrameTyp := -1; InsertTextRec(p, Round(y / (14 / ScaleY))); Pict.Free; Str.Free; Inc(ImgNumber); end; DataList.Clear; n := Lines.Count - 1; while n >= 0 do begin if Lines[n] <> nil then break; Dec(n); end; for i := 0 to n do begin p := PfrTextRec(Lines[i]); s := ''; IsEmpty := True; while p <> nil do begin IsEmpty := False; s1 := ''; s2 := ''; if p^.FrameTyp = -1 then begin s1 := ''; s := s + '' + s1 + ''; end else begin if (p^.FontColor = clWhite) or (p^.FontColor = clNone) then p^.FontColor := clBlack; if p^.FontColor <> clBlack then begin s1 := IntToHex(p^.FontColor, 6); s1 := 'Color="#' + Copy(s1, 5, 2) + Copy(s1, 3, 2) + Copy(s1, 1, 2) + '"'; end; if not (p^.FontSize in [10..13]) then s1 := s1 + ' Size=' + GetHTMLFontSize(p^.FontSize); if p^.FontStyle <> 0 then s2 := GetHTMLFontStyle(p^.FontStyle); if s1 <> '' then s1 := ''; s := s + '' + s1 + s2 + p^.Text + ''; end; p := p^.Next; end; if not KillEmptyLines or not IsEmpty then begin s := s + ''#13#10; Stream.Write(s[1], Length(s)); end; end; end; procedure TfrHTMExport.OnData(x, y: Integer; View: TfrView); var Str: TStream; b: Byte; Graphic: TGraphic; begin if ExportPictures then if View is TfrPictureView then begin Graphic := TfrPictureView(View).Picture.Graphic; if not ((Graphic = nil) or Graphic.Empty) then begin Str := TMemoryStream.Create; Str.Write(x, 4); Str.Write(y, 4); Str.Write(View.dx, 4); Str.Write(View.dy, 4); b := 0; {$IFDEF JPEG} if Graphic is TJPEGImage then b := 1; {$ENDIF} Str.Write(b, 1); Graphic.SaveToStream(Str); DataList.Add(Str); end; end; end; procedure TfrHTMExportForm.Localize; begin Caption := S54830; CB1.Caption := S54801; CB2.Caption := S54821; Label1.Caption := S54806; Button1.Caption := (SOk); Button2.Caption := (SCancel); end; procedure TfrHTMExportForm.FormCreate(Sender: TObject); begin Localize; end; end.