mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-10-31 22:10:55 +01:00
466 lines
12 KiB
ObjectPascal
466 lines
12 KiB
ObjectPascal
{******************************************************************}
|
|
{* IPHTMLPV.PAS - HTML Browser Print Preview *}
|
|
{******************************************************************}
|
|
|
|
(* ***** BEGIN LICENSE BLOCK *****
|
|
* Version: MPL 1.1
|
|
*
|
|
* The contents of this file are subject to the Mozilla Public License Version
|
|
* 1.1 (the "License"); you may not use this file except in compliance with
|
|
* the License. You may obtain a copy of the License at
|
|
* http://www.mozilla.org/MPL/
|
|
*
|
|
* Software distributed under the License is distributed on an "AS IS" basis,
|
|
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
|
* for the specific language governing rights and limitations under the
|
|
* License.
|
|
*
|
|
* The Original Code is TurboPower Internet Professional
|
|
*
|
|
* The Initial Developer of the Original Code is
|
|
* TurboPower Software
|
|
*
|
|
* Portions created by the Initial Developer are Copyright (C) 2000-2002
|
|
* the Initial Developer. All Rights Reserved.
|
|
*
|
|
* Contributor(s):
|
|
*
|
|
* ***** END LICENSE BLOCK ***** *)
|
|
|
|
{ Global defines potentially affecting this unit }
|
|
{$I IPDEFINE.INC}
|
|
|
|
unit IpHtmlPv;
|
|
|
|
{$IFNDEF Html_Print}
|
|
{$ERROR requires -dHTML_Print}
|
|
{$ENDIF}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF IP_LAZARUS}
|
|
LCLType,
|
|
GraphType,
|
|
LCLIntf,
|
|
Buttons,
|
|
{$ELSE}
|
|
Windows,
|
|
{$ENDIF}
|
|
Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
|
StdCtrls, ExtCtrls, Spin, IpHtml;
|
|
|
|
resourcestring
|
|
rsIpHTMLPreviewPrintPreview = 'Print preview';
|
|
rsIpHTMLPreviewPrint = 'Print';
|
|
rsIpHTMLPreviewZoom = 'Zoom:';
|
|
rsIpHTMLPreviewClose = 'Close';
|
|
rsIpHTMLPreviewFitAll = 'Fit all';
|
|
rsIpHTMLPreviewFitWidth = 'Width';
|
|
rsIpHTMLPreviewFitHeight = 'Height';
|
|
rsIpHTMLPreviewPage = 'Page:';
|
|
rsIpHTMLPreviewOf = 'of';
|
|
rsIpHTMLPreviewSelectPrinter = 'Select printer ...';
|
|
|
|
type
|
|
|
|
{ TIpHTMLPreview }
|
|
|
|
TIpHTMLPreview = class(TForm)
|
|
btnFitHeight: TButton;
|
|
btnFitWidth: TButton;
|
|
btnFit: TButton;
|
|
btnSelectPrinter: TButton;
|
|
Label3: TLabel;
|
|
PaperPanel: TPanel;
|
|
PaintBox1: TPaintBox;
|
|
edtZoom: TSpinEdit;
|
|
ToolbarPanel: TPanel;
|
|
btnPrint: TButton;
|
|
btnFirst: TButton;
|
|
btnPrev: TButton;
|
|
btnNext: TButton;
|
|
btnLast: TButton;
|
|
btnClose: TButton;
|
|
edtPage: TEdit;
|
|
Label1: TLabel;
|
|
Label2: TLabel;
|
|
lblMaxPage: TLabel;
|
|
ScrollBox1: TScrollBox;
|
|
procedure btnFirstClick(Sender: TObject);
|
|
procedure btnFitClick(Sender: TObject);
|
|
procedure btnFitHeightClick(Sender: TObject);
|
|
procedure btnFitWidthClick(Sender: TObject);
|
|
procedure btnLastClick(Sender: TObject);
|
|
procedure btnNextClick(Sender: TObject);
|
|
procedure btnPrevClick(Sender: TObject);
|
|
procedure btnPrintClick(Sender: TObject);
|
|
procedure btnSelectPrinterClick(Sender: TObject);
|
|
procedure edtPageChange(Sender: TObject);
|
|
procedure edtZoomChange(Sender: TObject);
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure FormDestroy(Sender: TObject);
|
|
procedure FormResize(Sender: TObject);
|
|
procedure FormShow(Sender: TObject);
|
|
procedure PaintBox1Paint(Sender: TObject);
|
|
private
|
|
SourceRect: TRect;
|
|
Scratch: TBitmap;
|
|
FScale: double;
|
|
FZoom: Integer;
|
|
FZoomToFit: Integer;
|
|
FLockZoomUpdate: Integer;
|
|
procedure SetCurPage(const Value: Integer);
|
|
procedure SetZoom(const Value: Integer);
|
|
protected
|
|
procedure AlignPaintBox;
|
|
procedure Render;
|
|
procedure ResizeCanvas;
|
|
// procedure ScaleSourceRect;
|
|
procedure UpdateBtnStates;
|
|
public
|
|
FCurPage: Integer;
|
|
HTML : TIpHtml;
|
|
PageRect: TRect;
|
|
OwnerPanel: TIpHtmlInternalPanel;
|
|
procedure RenderPage(PageNo: Integer);
|
|
property CurPage: Integer read FCurPage write SetCurPage;
|
|
property Scale: double read FScale;
|
|
property Zoom: Integer read FZoom write SetZoom;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
Printers;
|
|
|
|
{$IFNDEF IP_LAZARUS}
|
|
{$R *.DFM}
|
|
{$ELSE}
|
|
{$R *.lfm}
|
|
{$ENDIF}
|
|
|
|
const
|
|
SCRATCH_WIDTH = 800; //640;
|
|
SCRATCH_HEIGHT = 600; //480;
|
|
ZOOM_FACTOR = 1.1;
|
|
|
|
function ScaleRect(ARect: TRect; AFactor: Double): TRect;
|
|
begin
|
|
Result.Left := round(ARect.Left * AFactor);
|
|
Result.Top := round(ARect.Top * AFactor);
|
|
Result.Right := round(ARect.Right * AFactor);
|
|
Result.Bottom := round(ARect.Bottom * AFactor);
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.AlignPaintBox;
|
|
var
|
|
sb: Integer;
|
|
begin
|
|
sb := GetSystemMetrics(SM_CXVSCROLL);
|
|
if PaperPanel.Width < ClientWidth - sb then
|
|
PaperPanel.Left := (ClientWidth - sb - PaperPanel.Width) div 2
|
|
else
|
|
PaperPanel.Left := 0;
|
|
|
|
sb := GetSystemMetrics(SM_CXHSCROLL);
|
|
if PaperPanel.Height < ClientHeight - sb - ToolbarPanel.Height then
|
|
PaperPanel.Top := (ClientHeight - sb - ToolbarPanel.Height - PaperPanel.Height) div 2
|
|
else
|
|
PaperPanel.Top := 0;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.btnFirstClick(Sender: TObject);
|
|
begin
|
|
CurPage := 1;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.btnFitClick(Sender: TObject);
|
|
begin
|
|
SetZoom(ZOOM_TO_FIT);
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.btnFitHeightClick(Sender: TObject);
|
|
begin
|
|
SetZoom(ZOOM_TO_FIT_HEIGHT);
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.btnFitWidthClick(Sender: TObject);
|
|
begin
|
|
SetZoom(ZOOM_TO_FIT_WIDTH);
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.btnLastClick(Sender: TObject);
|
|
begin
|
|
CurPage := OwnerPanel.PageCount;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.btnNextClick(Sender: TObject);
|
|
begin
|
|
CurPage := CurPage + 1;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.btnPrevClick(Sender: TObject);
|
|
begin
|
|
CurPage := CurPage - 1;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.btnSelectPrinterClick(Sender: TObject);
|
|
begin
|
|
if OwnerPanel <> nil then
|
|
if OwnerPanel.SelectPrinterDlg then
|
|
SetZoom(Zoom); {force recalc of preview sizes}
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.btnPrintClick(Sender: TObject);
|
|
begin
|
|
Screen.Cursor := crHourglass;
|
|
ScaleFonts := False;
|
|
try
|
|
OwnerPanel.PrintPages(1, OwnerPanel.PageCount);
|
|
finally
|
|
ScaleFonts := True;
|
|
Screen.Cursor := crDefault;
|
|
Close;
|
|
end;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.edtPageChange(Sender: TObject);
|
|
begin
|
|
CurPage := StrToInt(edtPage.Text);
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.edtZoomChange(Sender: TObject);
|
|
var
|
|
newZoom: Double;
|
|
begin
|
|
if (FLockZoomUpdate = 0) and TryStrToFloat(edtZoom.Text, newZoom) then
|
|
SetZoom(Round(newZoom));
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.FormCreate(Sender: TObject);
|
|
begin
|
|
FZoom := 100;
|
|
FZoomToFit := ZOOM_TO_FIT;
|
|
Scratch := TBitmap.Create;
|
|
Scratch.Width := SCRATCH_WIDTH;
|
|
Scratch.Height := SCRATCH_HEIGHT;
|
|
|
|
// localization
|
|
Self.Caption := rsIpHTMLPreviewPrintPreview;
|
|
btnPrint.Caption := rsIpHTMLPreviewPrint;
|
|
Label3.Caption := rsIpHTMLPreviewZoom;
|
|
btnClose.Caption := rsIpHTMLPreviewClose;
|
|
Label1.Caption := rsIpHTMLPreviewPage;
|
|
Label2.Caption := rsIpHTMLPreviewOf;
|
|
btnSelectPrinter.Caption := rsIpHTMLPreviewSelectPrinter;
|
|
btnFit.Caption := rsIpHTMLPreviewFitAll;
|
|
btnFitWidth.Caption := rsIpHTMLPreviewFitWidth;
|
|
btnFitHeight.Caption := rsIpHTMLPreviewFitHeight;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.FormDestroy(Sender: TObject);
|
|
begin
|
|
Scratch.Free;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.FormResize(Sender: TObject);
|
|
begin
|
|
if (FZoomToFit <= 0) and (OwnerPanel <> nil) then
|
|
SetZoom(FZoomToFit) {force recalc of preview sizes}
|
|
else
|
|
AlignPaintbox;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.FormShow(Sender: TObject);
|
|
begin
|
|
UpdateBtnStates;
|
|
RenderPage(CurPage);
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.PaintBox1Paint(Sender: TObject);
|
|
begin
|
|
SourceRect := ScaleRect(PaintBox1.Canvas.ClipRect, 1.0/Scale);
|
|
OffsetRect(SourceRect, 0, PageRect.Top);
|
|
Render;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.Render;
|
|
var
|
|
TileTop, TileLeft,
|
|
WindowTop, WindowLeft: Integer;
|
|
R, Rscr: TRect;
|
|
begin
|
|
{GDI won't let us create a bitmap for a whole page
|
|
since it would become too big for large resolutions,
|
|
so we have to do banding by hand}
|
|
|
|
Screen.Cursor := crHourglass;
|
|
try
|
|
Application.ProcessMessages;
|
|
PaintBox1.Canvas.Brush.Color := clWhite;
|
|
PaintBox1.Canvas.FillRect(PaintBox1.Canvas.ClipRect);
|
|
PaintBox1.Canvas.AntialiasingMode := OwnerPanel.PreviewAntiAliasingMode;
|
|
WindowTop := SourceRect.Top;
|
|
TileTop := 0;
|
|
while WindowTop < SourceRect.Bottom do begin
|
|
WindowLeft := SourceRect.Left;
|
|
TileLeft := 0;
|
|
while WindowLeft < SourceRect.Right do begin
|
|
R.Left := WindowLeft;
|
|
R.Top := WindowTop;
|
|
R.Right := R.Left + SCRATCH_WIDTH + 1;
|
|
R.Bottom := R.Top + SCRATCH_HEIGHT + 1;
|
|
Rscr := R;
|
|
if R.Bottom - SourceRect.Top > OwnerPanel.PrintHeight then begin
|
|
Scratch.Canvas.FillRect(0, 0, R.Right-R.Left, R.Bottom-R.Top);
|
|
R.Bottom := SourceRect.Top + OwnerPanel.PrintHeight;
|
|
end;
|
|
|
|
HTML.Render(Scratch.Canvas, R, PageRect.Top, PageRect.Bottom, False, Point(0, 0));
|
|
|
|
OffsetRect(RScr, 0, -PageRect.Top);
|
|
Rscr := ScaleRect(Rscr, Scale);
|
|
PaintBox1.Canvas.StretchDraw(Rscr, Scratch);
|
|
|
|
inc(WindowLeft, SCRATCH_WIDTH);
|
|
inc(TileLeft, SCRATCH_WIDTH);
|
|
end;
|
|
inc(WindowTop, SCRATCH_HEIGHT);
|
|
inc(TileTop, SCRATCH_HEIGHT);
|
|
end;
|
|
finally
|
|
Screen.Cursor := crDefault;
|
|
end;
|
|
|
|
(*
|
|
This is an untiled version ...
|
|
var
|
|
R: TRect;
|
|
begin
|
|
// Render to single "scratch" bitmap which has the original print size and
|
|
// then is stretch-drawn into the preview paintbox.
|
|
Screen.Cursor := crHourglass;
|
|
try
|
|
Application.ProcessMessages;
|
|
Paintbox1.Canvas.Brush.Color := clWhite;
|
|
Paintbox1.Canvas.FillRect(Paintbox1.Canvas.ClipRect);
|
|
PaintBox1.Canvas.AntialiasingMode := OwnerPanel.PreviewAntiAliasingMode;
|
|
Scratch.Clear;
|
|
Scratch.Width := SourceRect.Right - SourceRect.Left;
|
|
Scratch.Height := SourceRect.Bottom - SourceRect.Top;
|
|
|
|
// probably not needed
|
|
Scratch.Canvas.Brush.Color := clWhite;
|
|
Scratch.Canvas.FillRect(SourceRect);
|
|
|
|
HTML.Render(Scratch.Canvas, SourceRect, PageRect.Top, PageRect.Bottom, False, Point(0, 0));
|
|
|
|
R := Paintbox1.Canvas.ClipRect;
|
|
PaintBox1.Canvas.StretchDraw(R, Scratch);
|
|
finally
|
|
Screen.Cursor := crDefault;
|
|
end;
|
|
*)
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.RenderPage(PageNo: Integer);
|
|
var
|
|
CR : TRect;
|
|
begin
|
|
CR := Rect(0, 0, OwnerPanel.PrintWidth, 0);
|
|
CR.Top := (PageNo - 1) * OwnerPanel.PrintHeight;
|
|
CR.Bottom := Cr.Top + OwnerPanel.PrintHeight;
|
|
PageRect := CR;
|
|
PaintBox1.Invalidate;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.ResizeCanvas;
|
|
begin
|
|
ScrollBox1.HorzScrollBar.Position := 0;
|
|
ScrollBox1.VertScrollBar.Position := 0;
|
|
{$IFDEF IP_LAZARUS}
|
|
if Printer.PageHeight > 0 then
|
|
PaperPanel.Height := round(Printer.PageHeight * Scale)
|
|
else
|
|
PaperPanel.Height := round(500 * Scale);
|
|
if Printer.PageWidth > 0 then
|
|
PaperPanel.Width := round(Printer.PageWidth * Scale)
|
|
else
|
|
PaperPanel.Width := round(500 * Scale);
|
|
{$ELSE}
|
|
PaperPanel.Width := round(Printer.PageWidth * Scale);
|
|
PaperPanel.Height := round(Printer.PageHeight * Scale);
|
|
{$ENDIF}
|
|
|
|
PaintBox1.Left := round(OwnerPanel.PrintTopLeft.x * Scale);
|
|
PaintBox1.Top := round(OwnerPanel.PrintTopLeft.y * Scale);
|
|
Paintbox1.Width := PaperPanel.Width - Paintbox1.Left;
|
|
Paintbox1.Height := PaperPanel.Height - Paintbox1.top;
|
|
|
|
AlignPaintBox;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.SetCurPage(const Value: Integer);
|
|
begin
|
|
if (Value <> FCurPage) and (Value >= 1) and (Value <= OwnerPanel.PageCount) then
|
|
begin
|
|
FCurPage := Value;
|
|
RenderPage(Value);
|
|
edtPage.Text := IntToStr(CurPage);
|
|
UpdateBtnStates;
|
|
end;
|
|
end;
|
|
|
|
procedure TIpHTMLPreview.SetZoom(const Value: Integer);
|
|
var
|
|
ClientHeightDbl, ClientWidthDbl: Double;
|
|
PrnPgHeight, PrnPgWidth: Double;
|
|
scaleW, scaleH: Integer;
|
|
sb: Integer;
|
|
begin
|
|
FZoomToFit := Value;
|
|
|
|
// Available client area in inches, without scrollbars
|
|
sb := GetSystemMetrics(SM_CXHSCROLL);
|
|
ClientHeightDbl := (ClientHeight - sb - ToolbarPanel.Height) / ScreenInfo.PixelsPerInchY;
|
|
sb := GetSystemMetrics(SM_CXVSCROLL);
|
|
ClientWidthDbl := (ClientWidth - sb)/ ScreenInfo.PixelsPerInchX;
|
|
|
|
// Printer page size in inches
|
|
PrnPgHeight := Printer.PageHeight / Printer.YDpi;
|
|
PrnPgWidth := Printer.PageWidth / Printer.XDpi;
|
|
|
|
case Value of
|
|
ZOOM_TO_FIT:
|
|
begin
|
|
scaleW := round(ClientWidthDbl / PrnPgWidth * 100);
|
|
scaleH := round(ClientHeightDbl / PrnPgHeight * 100);
|
|
if scaleW < scaleH then FZoom := scaleW else FZoom := scaleH;
|
|
end;
|
|
ZOOM_TO_FIT_WIDTH:
|
|
FZoom := round(ClientWidthDbl / PrnPgWidth * 100);
|
|
ZOOM_TO_FIT_HEIGHT:
|
|
FZoom := round(ClientHeightDbl / PrnPgHeight * 100);
|
|
else
|
|
FZoom := Value;
|
|
end;
|
|
inc(FLockZoomUpdate);
|
|
edtZoom.Value := FZoom;
|
|
dec(FLockZoomUpdate);
|
|
FScale := ScreenInfo.PixelsPerInchX / Printer.XDpi * FZoom * 0.01;
|
|
|
|
ResizeCanvas;
|
|
end;
|
|
|
|
procedure TIpHtmlPreview.UpdateBtnStates;
|
|
begin
|
|
btnFirst.Enabled := (FCurPage > 1);
|
|
btnPrev.Enabled := (FCurPage > 1);
|
|
btnNext.Enabled := (FCurPage < OwnerPanel.PageCount);
|
|
btnLast.Enabled := (FCurPage < OwnerPanel.PageCount);
|
|
end;
|
|
|
|
end.
|