'#13#10;
DefPrint = 'parent.mainFrame.focus(); parent.mainFrame.print();';
LinkPrint = 'parent.location = "%s";';
DefRefresh = 'parent.location = "result?report=" + frRepName + "&multipage=" + frMultipage;';
LinkRefresh = 'parent.location = "%s";';
{ TfrxHTMLExport }
constructor TfrxHTMLExport.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FExportPictures := True;
FExportStyles := True;
FFixedWidth := True;
FServer := False;
FPrintLink := '';
FBackground := False;
FCentered := False;
FBackImage := TBitmap.Create(0, 0);
FilterDesc := frxGet(8210);
DefaultExt := frxGet(8211);
FEmptyLines := True;
Files := TStringList.Create;
FUseTemplates := False;
FHTMLDocumentBegin := TStringList.Create;
FHTMLDocumentBegin.Add('');
FHTMLDocumentBegin.Add('');
FHTMLDocumentBegin.Add('');
FHTMLDocumentBegin.Add('');
FHTMLDocumentBody := TStringList.Create;
FHTMLDocumentEnd := TStringList.Create;
FHTMLDocumentEnd.Add('');
FURLTarget := '';
FPrint := false;
end;
class function TfrxHTMLExport.GetDescription: String;
begin
Result := frxResources.Get('HTMLexport');
end;
function TfrxHTMLExport.TruncReturns(const Str: WideString): WideString;
var
l: Integer;
begin
l := Length(Str);
if (l > 1) and (Str[l - 1] = #13) and (Str[l] = #10) then
Result := Copy(Str, 1, l - 2)
else
Result := Str;
end;
function TfrxHTMLExport.ChangeReturns(const Str: string): string;
function Hex(x: Byte): string;
const
d: string = '0123456789abcdef';
begin
Result := d[1 + x div 16] + d[1 + x mod 16];
end;
function HexColor(x: TColor): string;
var
r, g, b: Byte;
begin
r := x and 255;
g := (x shr 8) and 255;
b := (x shr 16) and 255;
Result := Hex(r) + Hex(g) + Hex(b);
end;
function EscapeSymbols(s: string): string;
var
i: Integer;
c: string;
begin
Result := '';
for i := 1 to Length(s) do
begin
c := s[i];
case s[i] of
'<': c := '<';
'>': c := '>';
'&': c := '&';
'"': c := '"';
#13: c := '';
#10:
if (i > 1) and (s[i - 1] = #13) then
c := ' ';
end;
Result := Result + c;
end;
end;
{ function TaggedStr(s: string; t: TfrxHTMLTag): string;
begin
s := EscapeSymbols(s);
if fsBold in t.Style then
s := '' + s + '';
if fsItalic in t.Style then
s := '' + s + '';
if fsUnderline in t.Style then
s := '' + s + '';
if fsStrikeOut in t.Style then
s := '' + s + '';
if t.Color <> 0 then
s := '' + s + '';
Result := s;
end; }
{var
i, j: Integer;
ht: TfrxHTMLTagsList;
LastTag, Tag: TfrxHTMLTag;
s: WideString;}
begin
{ s := Str;
ht := TfrxHTMLTagsList.Create;
ht.AllowTags := True;
ht.ExpandHTMLTags(s);
LastTag := nil;
s := '';
Result := '';
for i := 0 to ht.Count - 1 do
for j := 0 to ht[i].Count - 1 do
begin
Tag := ht[i][j];
if (LastTag <> nil) and ((LastTag.Style <> Tag.Style) or (LastTag.Color <> Tag.Color)) then
begin
Result := Result + TaggedStr(s, LastTag);
s := '';
end;
s := s + Str[Tag.Position + 1];
LastTag := Tag;
end;
if s <> '' then
Result := Result + TaggedStr(s, LastTag);
ht.Free; }
//todo
Result := Str;
end;
procedure TfrxHTMLExport.WriteExpLn(const str: String);
var
TempStr: AnsiString;
begin
TempStr := UTF8Encode(str);
Exp.Write(TempStr[1], Length(TempStr));
Exp.Write(AnsiChar(#13)+AnsiChar(#10), 2);
end;
procedure TfrxHTMLExport.WriteExpLnA(const str: AnsiString);
begin
Exp.Write(str[1], Length(str));
Exp.Write(AnsiChar(#13)+AnsiChar(#10), 2);
end;
procedure TfrxHTMLExport.ExportPage;
var
i, x, y, dx, dy, fx, fy, pbk: Integer;
dcol, drow: Integer;
text, buff: String;
s, s1, sb, si, su: String;
Vert, Horiz: String;
obj: TfrxIEMObject;
EStyle: TfrxIEMStyle;
St: String;
hlink, newpage: Boolean;
tableheader, columnWidths: String;
procedure AlignFR2AlignExcel(HAlign: TfrxHAlign; VAlign: TfrxVAlign;
var AlignH, AlignV: String);
begin
if HAlign = haLeft then
AlignH := 'Left'
else if HAlign = haRight then
AlignH := 'Right'
else if HAlign = haCenter then
AlignH := 'Center'
else if HAlign = haBlock then
AlignH := 'Justify'
else
AlignH := '';
if VAlign = vaTop then
AlignV := 'Top'
else if VAlign = vaBottom then
AlignV := 'Bottom'
else if VAlign = vaCenter then
AlignV := 'Middle'
else
AlignV := '';
end;
begin
WriteExpLn(FHTMLDocumentBegin.Text);
if FPrint then
WriteExpLn('');
if Length(Report.ReportOptions.Name) > 0 then
s := Report.ReportOptions.Name
else
s := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(Report.FileName)), '');
WriteExpLnA('' + UTF8Encode(s) + '');
if FExportStyles then
begin
WriteExpLn('');
end;
WriteExpLn('');
WriteExpLn('');
WriteExpLn(FHTMLDocumentBody.Text);
WriteExpLn('');
if FFixedWidth then
st := ' width="' + IntToStr(Round((FMatrix.MaxWidth - FMatrix.Left) / Xdivider)) + '"'
else
st := '';
if FCentered then
st := st + ' align="center"';
tableheader := '');
columnWidths := '
';
for x := 0 to FMatrix.Width - 2 do
begin
dcol := Round((FMatrix.GetXPosById(x + 1) - FMatrix.GetXPosById(x)) / Xdivider);
columnWidths := columnWidths + '
';
end;
if FMatrix.Width < 2 then
columnWidths := columnWidths + '
';
columnWidths := columnWidths + '
';
WriteExpLn(columnWidths);
pbk := 0;
st := '';
newpage := False;
for y := 0 to FMatrix.Height - 2 do
begin
if ShowProgress and (not FMultipage) then
if FProgress.Terminated then
break;
drow := Round((FMatrix.GetYPosById(y + 1) - FMatrix.GetYPosById(y)) / Ydivider);
s := '';
if FMatrix.PagesCount > pbk then
if Round(FMatrix.GetPageBreak(pbk)) <= Round(FMatrix.GetYPosById(y + 1)) then
begin
Inc(pbk);
if ShowProgress and (not FMultipage) then
FProgress.Tick;
newpage := True;
end;
if drow = 0 then
drow := 1;
WriteExpLn('
');
if newpage then
begin
WriteExpLn('');
newpage := False;
if y < FMatrix.Height - 2 then
begin
WriteExpLn('');
WriteExpLn(tableheader + ' class="page_break">');
WriteExpLn(columnWidths);
end;
end;
end;
if FMultipage or (FMatrix.Height < 2) then
WriteExpLn('');
WriteExpLn(FHTMLDocumentEnd.Text);
end;
function TfrxHTMLExport.ShowModal: TModalResult;
begin
if not Assigned(Stream) then
begin
with TfrxHTMLExportDialog.Create(nil) do
begin
//SendMessage(GetWindow(PFormatCB.Handle,GW_CHILD), EM_SETREADONLY, 1, 0);
OpenAfterCB.Visible := not SlaveExport;
MultipageCB.Enabled := not SlaveExport;
BackgrCB.Enabled := not SlaveExport;
NavigatorCB.Enabled := not SlaveExport;
PicsSameCB.Enabled := not SlaveExport;
if OverwritePrompt then
SaveDialog1.Options := SaveDialog1.Options + [TOpenOption.ofOverwritePrompt];
if SlaveExport then
begin
FOpenAfterExport := False;
FExportPictures := True;
FPicsInSameFolder := True;
FNavigator := False;
FMultipage := False;
FBackground := False;
end;
if (FileName = '') and (not SlaveExport) then
SaveDialog1.FileName := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(Report.FileName)), SaveDialog1.DefaultExt)
else
SaveDialog1.FileName := FileName;
StylesCB.IsChecked := FExportStyles;
PicsSameCB.IsChecked := FPicsInSameFolder;
if not FExportPictures then
PFormatCB.ItemIndex := 0
else
case PictureType of
gpBMP: PFormatCB.ItemIndex := 2;
gpJPG: PFormatCB.ItemIndex := 1;
gpGIF: PFormatCB.ItemIndex := 3;
else PFormatCB.ItemIndex := 1;
end;
OpenAfterCB.IsChecked := FOpenAfterExport;
FixWidthCB.IsChecked := FFixedWidth;
NavigatorCB.IsChecked := FNavigator;
MultipageCB.IsChecked := FMultipage;
BackgrCB.IsChecked := FBackground;
if PageNumbers <> '' then
begin
PageNumbersE.Text := PageNumbers;
PageNumbersRB.IsChecked := True;
end;
Result := ShowModal;
PeekLastModalResult;
if Result = mrOk then
begin
PageNumbers := '';
CurPage := False;
if CurPageRB.IsChecked then
CurPage := True
else if PageNumbersRB.IsChecked then
PageNumbers := PageNumbersE.Text;
FExportStyles := StylesCB.IsChecked;
FPicsInSameFolder := PicsSameCB.IsChecked;
FExportPictures := PFormatCB.ItemIndex > 0;
case PFormatCB.ItemIndex of
1: PictureType := gpJPG;
2: PictureType := gpBMP;
3: PictureType := gpGIF;
else PictureType := gpPNG;
end;
FOpenAfterExport := OpenAfterCB.IsChecked;
FFixedWidth := FixWidthCB.IsChecked;
FMultipage := MultipageCB.IsChecked;
FNavigator := NavigatorCB.IsChecked;
FBackground := BackgrCB.IsChecked;
if not SlaveExport then
begin
if DefaultPath <> '' then
SaveDialog1.InitialDir := DefaultPath;
if SaveDialog1.Execute then
FileName := SaveDialog1.FileName
else
Result := mrCancel;
PeekLastModalResult;
end;
end;
Free;
end
end else
Result := mrOk;
end;
function TfrxHTMLExport.Start: Boolean;
begin
if SlaveExport then
begin
FOpenAfterExport := False;
FExportPictures := True;
FPicsInSameFolder := True;
FNavigator := False;
FMultipage := False;
FBackground := False;
if Report.FileName <> '' then
FileName := ChangeFileExt(GetTemporaryFolder + ExtractFileName(Report.FileName), frxGet(8211))
else
FileName := ChangeFileExt(GetTempFile, frxGet(8211));
end;
if (FileName <> '') or Assigned(Stream) then
begin
if (ExtractFilePath(FileName) = '') and (DefaultPath <> '') then
FileName := DefaultPath + PathDelim + FileName;
FCurrentPage := 0;
FPicturesCount := 0;
FMatrix := TfrxIEMatrix.Create(UseFileCache, Report.EngineOptions.TempDir);
FMatrix.Report := Report;
if not FMultipage then
FMatrix.ShowProgress := ShowProgress
else
FMatrix.ShowProgress := False;
FMatrix.Inaccuracy := 0.5;
FMatrix.RotatedAsImage := True;
FMatrix.FramesOptimization := True;
FMatrix.Background := FBackground;
FMatrix.BackgroundImage := False;
FMatrix.Printable := ExportNotPrintable;
FMatrix.RichText := True;
FMatrix.PlainRich := True;
FMatrix.EmptyLines := EmptyLines;
if Assigned(Stream) then
begin
FMultipage := False;
FExportPictures := False;
FNavigator := False;
end;
Result := True
end
else
Result := False;
Files.Clear;
end;
procedure TfrxHTMLExport.StartPage(Page: TfrxReportPage; Index: Integer);
begin
Inc(FCurrentPage);
FBackImageExist := False;
FBackImage.Width := 0;
FBackImage.Height := 0;
end;
procedure TfrxHTMLExport.ExportObject(Obj: TfrxComponent);
begin
if (Obj is TfrxView) and (ExportNotPrintable or TfrxView(Obj).Printable) then
begin
if (Obj is TfrxCustomMemoView) or (Obj is TfrxLineView) or
(FExportPictures and (not (Obj is TfrxCustomMemoView))) then
FMatrix.AddObject(TfrxView(Obj));
if (TfrxView(Obj).Name = '_pagebackground') and FExportPictures and FBackground then
begin
FBackImageExist := True;
FBackImage.Width := Round(TfrxView(Obj).Width);
FBackImage.Height := Round(TfrxView(Obj).Height);
FBackImage.Canvas.BeginScene();
try
TfrxView(Obj).Draw(FBackImage.Canvas ,1, 1, -TfrxView(Obj).AbsLeft, -TfrxView(Obj).AbsTop);
finally
FBackImage.Canvas.EndScene;
end;
end;
end;
end;
procedure TfrxHTMLExport.FinishPage(Page: TfrxReportPage; Index: Integer);
var
s: String;
begin
if FMultipage then
begin
FMatrix.Prepare;
try
s := GetPicsFolder + IntToStr(FCurrentPage) + '.html';
Files.Add(s);
Exp := TFileStream.Create(s, fmCreate);
try
ExportPage;
finally
FMatrix.Clear;
Exp.Free;
end;
except
on e: Exception do
case Report.EngineOptions.NewSilentMode of
simSilent: Report.Errors.Add(e.Message);
simMessageBoxes: frxErrorMsg(e.Message);
simReThrow: raise;
end;
end;
end
else FMatrix.AddPage(Page.Orientation, Page.Width, Page.Height, Page.LeftMargin,
Page.TopMargin, Page.RightMargin, Page.BottomMargin, Page.MirrorMargins, Index);
end;
procedure TfrxHTMLExport.Finish;
var
s, st, print: String;
serv, Refresh: String;
TempString: AnsiString;
begin
if not FMultipage then
begin
if ShowProgress then
begin
FProgress := TfrxProgress.Create(nil);
FProgress.Execute(FCurrentPage - 1, frxResources.Get('ProgressWait'), true, true);
end;
FMatrix.Prepare;
try
if ShowProgress then
if FProgress.Terminated then
Exit;
if not Assigned(Stream) then
begin
if FNavigator then
begin
s := GetPicsFolder + 'main.html';
Files.Add(s);
Exp := TFileStream.Create(s, fmCreate);
end
else
begin
Exp := TFileStream.Create(FileName, fmCreate);
Files.Add(FileName);
end;
end
else
Exp := Stream;
try
ExportPage;
finally
FMatrix.Clear;
if not Assigned(Stream) then
Exp.Free;
end;
except
on e: Exception do
case Report.EngineOptions.NewSilentMode of
simSilent: Report.Errors.Add(e.Message);
simMessageBoxes: frxErrorMsg(e.Message);
simReThrow: raise;
end;
end;
if ShowProgress then
FProgress.Free;
end;
if FNavigator then
begin
try
s := GetPicsFolder + 'nav.html';
Files.Add(s);
Exp := TFileStream.Create(s, fmCreate);
try
if not FUseTemplates then
begin
if FMultipage then
s := '1'
else
s := '0';
st := '';
if FPicsInSameFolder then
st := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.');
if FServer then
serv := Format(Server_sect, [UTF8Encode(frxResources.Get('HTMLNavRefresh')), UTF8Encode(frxResources.Get('HTMLNavPrint'))])
else
serv := '';
if Length(FPrintLink) > 0 then
print := Format(LinkPrint, [FPrintLink])
else
print := DefPrint;
if Length(FRefreshLink) > 0 then
refresh := Format(LinkRefresh, [FRefreshLink])
else
refresh := DefRefresh;
WriteExpLn(Format(Navigator_src, [
IntToStr(FCurrentPage),
HTMLCodeStr(StringReplace(Report.FileName, FReportPath, '', [])),
s, st, Refresh, print,
UTF8Encode(frxResources.Get('HTMLNavFirst')),
UTF8Encode(frxResources.Get('HTMLNavPrev')),
UTF8Encode(frxResources.Get('HTMLNavNext')),
UTF8Encode(frxResources.Get('HTMLNavLast')),
serv, UTF8Encode(frxResources.Get('HTMLNavTotal'))]));
end
else
begin
if Assigned(FGetNavTemplate) then
begin
s := '';
FGetNavTemplate(HTMLCodeStr(StringReplace(Report.FileName, FReportPath, '', [])),
FMultipage, FPicsInSameFolder,
ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.'),
FCurrentPage,
s
);
TempString := UTF8Encode(s);
Exp.Write(TempString[1], Length(TempString));
end;
end;
finally
Exp.Free;
end;
except
on e: Exception do
case Report.EngineOptions.NewSilentMode of
simSilent: Report.Errors.Add(e.Message);
simMessageBoxes: frxErrorMsg(e.Message);
simReThrow: raise;
end;
end;
try
Files.Add(FileName);
Exp := TFileStream.Create(FileName, fmCreate);
try
if Length(Report.ReportOptions.Name) > 0 then
s := Report.ReportOptions.Name
else
s := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(Report.FileName)), '');
if not FUseTemplates then
begin
WriteExpLn('');
WriteExpLn('');
WriteExpLnA('' + UTF8Encode(s) + '');
WriteExpLn('');
WriteExpLn('');
WriteExpLn('');
WriteExpLn('');
end
else
begin
if Assigned(FGetMainTemplate) then
begin
st := '';
FGetMainTemplate(
String(UTF8Encode(s)), // title
ReverseSlash(GetFrameFolder), // frame folder
FMultipage, // multipage
st
);
TempString := UTF8Encode(st);
Exp.Write(TempString[1], Length(TempString));
end;
end;
finally
Exp.Free;
end;
except
on e: Exception do
case Report.EngineOptions.NewSilentMode of
simSilent: Report.Errors.Add(e.Message);
simMessageBoxes: frxErrorMsg(e.Message);
simReThrow: raise;
end;
end;
end;
FMatrix.Free;
//todo
if FOpenAfterExport and (not Assigned(Stream)) then
if FMultipage and (not FNavigator) then
{$IFDEF MSWINDOWS}
ShellExecute(0, 'open', PChar(GetPicsFolder + '1.html'), '', '', 5)
{$ENDIF}
{$IFDEF LINUX}
FmuxOpenFile(PChar(GetPicsFolder + '1.html'))
{$ENDIF}
{$IFDEF MACOS}
ShellExecute(GetPicsFolder + '1.html')
{$ENDIF}
else
{$IFDEF MSWINDOWS}
ShellExecute(0, 'open', PChar(FileName), '', '', 5);
{$ENDIF}
{$IFDEF LINUX}
FmuxOpenFile(PChar(FileName));
{$ENDIF}
{$IFDEF MACOS}
ShellExecute(FileName);
{$ENDIF}
end;
function TfrxHTMLExport.GetPicsFolderRel: String;
begin
if FPicsInSameFolder then
Result := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.')
else if FMultipage then
Result := ''
else if FAbsLinks then
Result := ExtractFilePath(FileName) + ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)),'.files') + PathDelim
else if FNavigator then
Result := ''
else
Result := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)),'.files') + PathDelim
end;
function TfrxHTMLExport.GetFrameFolder: String;
begin
if not FPicsInSameFolder then
Result := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)),'.files') + PathDelim
else
Result := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.');
end;
function TfrxHTMLExport.GetPicsFolder: String;
{var
SecAtrtrs: TSecurityAttributes; }
begin
if FPicsInSameFolder then
begin
if FAbsLinks then
Result := ExtractFilePath(FileName) + ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.')
else
Result := ChangeFileExt(frxUnixPath2WinPath(FileName), '.') //ExtractFileName
end
else
begin
if FAbsLinks then
Result := ExtractFilePath(FileName) + ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.files')
else
Result := ChangeFileExt(frxUnixPath2WinPath(FileName), '.files'); //ExtractFileName
{ SecAtrtrs.nLength := SizeOf(TSecurityAttributes);
SecAtrtrs.lpSecurityDescriptor := nil;
SecAtrtrs.bInheritHandle := True;
CreateDirectory(PChar(Result), @SecAtrtrs); }
CreateDir(Result);
Result := Result + PathDelim;
end;
end;
function TfrxHTMLExport.ReverseSlash(const S: String): String;
begin
Result := StringReplace(S, '\', '/', [rfReplaceAll]);
end;
destructor TfrxHTMLExport.Destroy;
begin
FHTMLDocumentBegin.Free;
FHTMLDocumentBody.Free;
FHTMLDocumentEnd.Free;
FBackImage.Free;
Files.Free;
Files := nil;
inherited;
end;
function TfrxHTMLExport.HTMLCodeStr(const Str: String): String;
var
i: Integer;
c: Char;
s: String;
function StrToHex(const s: String): String;
var
Len, i: Integer;
C, H, L: Byte;
function HexChar(N : Byte) : Char;
begin
if (N < 10) then Result := Chr(Ord('0') + N)
else Result := Chr(Ord('A') + (N - 10));
end;
begin
Len := Length(s);
SetLength(Result, Len shl 1);
for i := 1 to Len do begin
C := Ord(s[i]);
H := (C shr 4) and $f;
L := C and $f;
Result[i shl 1 - 1] := HexChar(H);
Result[i shl 1]:= HexChar(L);
end;
end;
begin
Result := '';
for i := 1 to Length(Str) do
begin
c := Str[i];
case c of
'0'..'9', 'A'..'Z', 'a'..'z': Result := Result + c;
else begin
s := c;
Result := Result + '%' + StrToHex(s);
end
end;
end;
end;
{ TfrxHTMLExportDialog }
procedure TfrxHTMLExportDialog.FormCreate(Sender: TObject);
begin
Caption := frxGet(8200);
OkB.Text := frxGet(1);
CancelB.Text := frxGet(2);
GroupPageRange.Text := frxGet(7);
AllRB.Text := frxGet(3);
CurPageRB.Text := frxGet(4);
PageNumbersRB.Text := frxGet(5);
DescrL.Text := frxGet(9);
GroupQuality.Text := frxGet(8);
OpenAfterCB.Text := frxGet(8201);
StylesCB.Text := frxGet(8202);
PicturesL.Text := frxGet(8203);
PicsSameCB.Text := frxGet(8204);
FixWidthCB.Text := frxGet(8205);
NavigatorCB.Text := frxGet(8206);
MultipageCB.Text := frxGet(8207);
BackgrCB.Text := frxGet(8209);
SaveDialog1.Filter := frxGet(8210);
SaveDialog1.DefaultExt := frxGet(8211);
PFormatCB.Items[0] := frxGet(8313);
{$IFDEF LINUX}
BorderStyleSizeable(Self);
{$ENDIF}
// if UseRightToLeftAlignment then
// FlipChildren(True);
end;
procedure TfrxHTMLExportDialog.PageNumbersEChange(Sender: TObject);
begin
PageNumbersRB.IsChecked := True;
end;
procedure TfrxHTMLExportDialog.PageNumbersEKeyPress(Sender: TObject;
var Key: Char);
begin
case key of
'0'..'9':;
#8, '-', ',':;
else
key := #0;
end;
end;
procedure TfrxHTMLExportDialog.FormKeyDown(Sender: TObject; var Key: Word;
var KeyChar: WideChar; Shift: TShiftState);
begin
{if Key = VK_F1 then
frxResources.Help(Self); }
end;
end.