📄 fr_e_htm.pas
字号:
{******************************************}
{ }
{ FastReport v2.4 }
{ HTM export filter }
{ }
{ Copyright (c) 1998-2001 by Tzyganenko A. }
{ }
{******************************************}
unit FR_E_HTM;
interface
{$I FR.inc}
uses
SysUtils, Windows, Messages, Classes, Graphics, Forms, StdCtrls,
FR_Class, FR_E_TXT, Controls;
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 *.DFM}
{ TfrHTMExport }
constructor TfrHTMExport.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
frRegisterExportFilter(Self, frLoadStr(SHTMFile) + ' (*.htm)', '*.htm');
ShowDialog := True;
ScaleY := 1;
KillEmptyLines := True;
ExportPictures := False;
end;
procedure TfrHTMExport.OnBeginDoc;
var
s: String;
begin
DataList := TList.Create;
s := '<HTML>'#13#10'<Body bgColor="#FFFFFF">'#13#10'<Table>'#13#10;
Stream.Write(s[1], Length(s));
ImgNumber := 0;
end;
procedure TfrHTMExport.OnEndDoc;
var
s: String;
begin
s := '</Table>'#13#10'</Body>'#13#10'</HTML>'#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 := '<i>';
if (Style and $2) <> 0 then Result := Result + '<b>';
if (Style and $4) <> 0 then Result := Result + '<u>';
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 := '<tr>';
IsEmpty := True;
while p <> nil do
begin
IsEmpty := False;
s1 := ''; s2 := '';
if p^.FrameTyp = -1 then
begin
s1 := '<img src="' + p^.Text + '" width="' +
IntToStr(p^.DrawRect.Right) + '" height="' +
IntToStr(p^.DrawRect.Bottom) + '">';
s := s + '<td>' + s1 + '</td>';
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 := '<Font ' + s1 + '>';
s := s + '<td>' + s1 + s2 + p^.Text + '</td>';
end;
p := p^.Next;
end;
if not KillEmptyLines or not IsEmpty then
begin
s := s + '</tr>'#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 := frLoadStr(frRes + 1830);
CB1.Caption := frLoadStr(frRes + 1801);
CB2.Caption := frLoadStr(frRes + 1821);
Label1.Caption := frLoadStr(frRes + 1806);
Button1.Caption := frLoadStr(SOk);
Button2.Caption := frLoadStr(SCancel);
end;
procedure TfrHTMExportForm.FormCreate(Sender: TObject);
begin
Localize;
end;
end.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -